Collection of Tools & Utilities

home *** CD-ROM | disk | FTP | other *** search

/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / tex / ptf12.zip / PTFBODY.SRC < prev next >

Wrap

Text File | 1990-05-12 | 176KB | 6,277 lines

--:::::::::: --clp_body.a --:::::::::: -- ********************************************** -- * * -- * COMMAND_LINE_PROCESSOR * BODY -- * * -- ********************************************** with CLI; -- from CLI2.SRC with TEXT_IO; package body COMMAND_LINE_PROCESSOR is NUMBER_OF_FILE_NAME_TOKENS : NATURAL; INIT_DONE : BOOLEAN := FALSE; OUTPUT_FILE_EXISTS : BOOLEAN := FALSE; type FNAME (LEN : NATURAL); type FNAME_POINTER is access FNAME; type FNAME (LEN : NATURAL) is record NAME : STRING (1 .. LEN); NEXT : FNAME_POINTER; end record; FIRST_FILE : FNAME_POINTER := null; CURRENT_FILE : FNAME_POINTER := null; LAST_FILE : FNAME_POINTER := null; -- ........................................... -- . . -- . ADD_FILE_NAME . SPEC & BODY -- . . -- ........................................... procedure ADD_FILE_NAME (FILE_NAME : in STRING) is --| Purpose --| ADD_FILE_NAME adds the named file to the file list, building --| onto a linked-list. If FILE_NAME is an include file, --| all files named by this include file and the include files --| it references are added to the list. --| --| Notes --| ADD_FILE_NAME is recursive. FD : TEXT_IO.FILE_TYPE; type INLINE is record CONTENT : STRING (1 .. MAX_FILE_NAME_LENGTH); LAST : NATURAL; end record; FILE : INLINE; -- ........................................... -- . . -- . ADD_FILE_NAME.IS_COMMENT . SPEC & BODY -- . . -- ........................................... function IS_COMMENT (ITEM : in INLINE) return BOOLEAN is --| Purpose --| Determine if the indicated ITEM is a comment line --| (begins with a "--"). begin return ITEM.LAST > 1 and then ITEM.CONTENT(1..2) = "--"; end IS_COMMENT; -- ........................................... -- . . -- . ADD_FILE_NAME.ADD_NAME_TO_LIST . SPEC & BODY -- . . -- ........................................... procedure ADD_NAME_TO_LIST (FILE_NAME : in STRING) is --| Purpose --| Add the indicated FILE_NAME to the linked list. TEMP : FNAME_POINTER; begin begin TEMP := new FNAME (FILE_NAME'LENGTH); TEMP.NAME := FILE_NAME; TEMP.NEXT := null; -- not necessary, but clear exception when others => raise ALLOCATION_PROBLEM; end; if FIRST_FILE = null then FIRST_FILE := TEMP; LAST_FILE := FIRST_FILE; CURRENT_FILE := FIRST_FILE; else LAST_FILE.NEXT := TEMP; LAST_FILE := TEMP; end if; end ADD_NAME_TO_LIST; begin -- ADD_FILE_NAME if FILE_NAME (FILE_NAME'FIRST) /= INCLUDE_FILE_PREFIX then ADD_NAME_TO_LIST (FILE_NAME); else -- Process include file begin TEXT_IO.OPEN (FD, TEXT_IO.IN_FILE, FILE_NAME (FILE_NAME'FIRST + 1 .. FILE_NAME'LAST)); exception when others => raise INCLUDE_FILE_NOT_FOUND; end; -- Loop through file while not TEXT_IO.END_OF_FILE (FD) loop TEXT_IO.GET_LINE (FD, FILE.CONTENT, FILE.LAST); if FILE.LAST > 0 and then not IS_COMMENT(FILE) then if FILE.CONTENT (1) = INCLUDE_FILE_PREFIX then ADD_FILE_NAME (FILE.CONTENT (1 .. FILE.LAST)); else ADD_NAME_TO_LIST (FILE.CONTENT (1 .. FILE.LAST)); end if; end if; end loop; -- Close include file TEXT_IO.CLOSE (FD); end if; exception when INCLUDE_FILE_NOT_FOUND | ALLOCATION_PROBLEM => raise; when others => raise UNEXPECTED_ERROR; end ADD_FILE_NAME; -- .............................................. -- . . -- . INITIALIZE . BODY -- . . -- .............................................. procedure INITIALIZE (PROGRAM_NAME : in STRING; COMMAND_KIND : in COMMAND_LINE_LAYOUT := ONE_OUTPUT_FILE) is begin if COMMAND_KIND = ONE_OUTPUT_FILE then CLI.INITIALIZE(PROGRAM_NAME, "Enter input file names and output file name: "); NUMBER_OF_FILE_NAME_TOKENS := CLI.ARGC - 1; for I in 1 .. NUMBER_OF_FILE_NAME_TOKENS - 1 loop ADD_FILE_NAME(CLI.ARGV(I)); end loop; OUTPUT_FILE_EXISTS := TRUE; else CLI.INITIALIZE(PROGRAM_NAME, "Enter input file names: "); NUMBER_OF_FILE_NAME_TOKENS := CLI.ARGC - 1; for I in 1 .. NUMBER_OF_FILE_NAME_TOKENS loop ADD_FILE_NAME(CLI.ARGV(I)); end loop; OUTPUT_FILE_EXISTS := FALSE; end if; INIT_DONE := TRUE; exception when ALLOCATION_PROBLEM => raise; when others => raise UNEXPECTED_ERROR; end INITIALIZE; -- .............................................. -- . . -- . RESET . BODY -- . . -- .............................................. procedure RESET is begin if not INIT_DONE then raise INIT_ERROR; else CURRENT_FILE := FIRST_FILE; end if; exception when INIT_ERROR => raise; when others => raise UNEXPECTED_ERROR; end RESET; -- .............................................. -- . . -- . IS_END . BODY -- . . -- .............................................. function IS_END return BOOLEAN is begin if not INIT_DONE then raise INIT_ERROR; else return CURRENT_FILE = null; end if; exception when INIT_ERROR => raise; when others => raise UNEXPECTED_ERROR; end IS_END; -- .............................................. -- . . -- . FILE_NAME . BODY -- . . -- .............................................. function FILE_NAME return STRING is TEMP : FNAME_POINTER; begin if not INIT_DONE then raise INIT_ERROR; else if IS_END then raise END_OF_FILE_LIST; end if; TEMP := CURRENT_FILE; CURRENT_FILE := CURRENT_FILE.NEXT; return TEMP.NAME; end if; exception when INIT_ERROR => raise; when END_OF_FILE_LIST => raise; when others => raise UNEXPECTED_ERROR; end FILE_NAME; -- .............................................. -- . . -- . OUTPUT_FILE_NAME . BODY -- . . -- .............................................. function OUTPUT_FILE_NAME return STRING is begin if not INIT_DONE then raise INIT_ERROR; else if OUTPUT_FILE_EXISTS then return CLI.ARGV(NUMBER_OF_FILE_NAME_TOKENS); else return ""; end if; end if; exception when INIT_ERROR => raise; when others => raise UNEXPECTED_ERROR; end OUTPUT_FILE_NAME; -- .............................................. -- . . -- . FILE_NAME_COUNT . BODY -- . . -- .............................................. function FILE_NAME_COUNT return NATURAL is begin if not INIT_DONE then raise INIT_ERROR; else return NUMBER_OF_FILE_NAME_TOKENS; end if; exception when INIT_ERROR => raise; when others => raise UNEXPECTED_ERROR; end FILE_NAME_COUNT; end COMMAND_LINE_PROCESSOR; --:::::::::: --cmd_body.a --:::::::::: -- ********************************** -- * * -- * Command * BODY -- * * -- ********************************** with Console; with Contents; with Environment; with Error_Log; with Index; with Input_File; with Macro; with Parse; with Variable; with Word_Processor; package body Command is --| Notes (none) --| --| Modifications --| 08/16/89 Rick Conn Initial Version --| 02/26/90 Rick Conn Add Disable Underline --| 02/26/90 Rick Conn Add trim of tail as well as front Default_Bottom : constant NATURAL := Formatted_Output_File.Page_Attribute_Defaults (Formatted_Output_File.Bottom_Margin); Default_Footer : constant NATURAL := Formatted_Output_File.Page_Attribute_Defaults (Formatted_Output_File.Footer_Lines); Default_Header : constant NATURAL := Formatted_Output_File.Page_Attribute_Defaults (Formatted_Output_File.Header_Lines); Default_Top : constant NATURAL := Formatted_Output_File.Page_Attribute_Defaults (Formatted_Output_File.Top_Margin); Default_Contents_Indentation : constant NATURAL := 3; Is_Bolding : BOOLEAN := true; Is_Underlining : BOOLEAN := true; Last_Contents_Indent : NATURAL := 0; Index_File_Name : constant STRING := "ptf.idx"; Index_Is_Open : BOOLEAN := false; Index_Line_Length : NATURAL := 35; package Fof renames Formatted_Output_File; use Command_Symbols; -- for visibility of "=" use Formatted_Output_File; use Macro; use Word_Processor; -- .................................. -- . . -- . Convert . SPEC & BODY -- . . -- .................................. function Convert ( Item : in STRING ) return Command_Text is --| Purpose --| Convert converts the passed string into a string of type --| COMMAND_TEXT. If the passed string is longer than COMMAND_TEXT, --| it is truncated; --| --| Exceptions (none) --| Notes (none) Result : Command_Text := (others => ' '); Item_Start : NATURAL := Item'First; Item_End : NATURAL := Item'First + Command_Text'Length - 1; begin -- Convert if Item'Length <= Command_Text'Length then Result(1 .. Item'Length) := Item; else Result := Item(Item_Start .. Item_End); end if; return Result; end Convert; -- .................................. -- . . -- . Spaces . SPEC & BODY -- . . -- .................................. function Spaces ( Number : in NATURAL ) return STRING is --| Purpose --| Spaces generates a string of the indicated number of spaces. --| --| Exceptions (none) --| Notes (none) Result : STRING (1 .. Number + 1) := (others => ' '); begin -- Spaces return Result(1 .. Number); end Spaces; -- .................................. -- . . -- . To_Nat . SPEC & BODY -- . . -- .................................. function To_Nat ( Number : in STRING ) return NATURAL is --| Purpose --| To_Nat converts a string of digits to a natural number with --| error checking. --| --| Exceptions (none) --| Notes (none) Result : NATURAL; begin -- To_Nat Result := NATURAL'Value(Number); return Result; exception -- To_Nat -- To_Nat when others => Error_Log.Write_Error(Error_Number & """" & Number & """"); return 0; end To_Nat; -- .................................. -- . . -- . Adjust . SPEC & BODY -- . . -- .................................. function Adjust ( Original_Value : in NATURAL; Text : in STRING ) return NATURAL is --| Purpose --| Adjust accepts strings of the form "n", "+n", and "-n", --| converts the "n" to a natural number, and, if "+n" or "-n", --| adjusts the Original_Value by that amount. If "n", it ignores --| the Original_Value and just returns that amount. --| --| Exceptions (none) --| Notes (none) Result : NATURAL := Original_Value; Temp : NATURAL; type OPERATION is ( INCREMENT, DECREMENT, SET ); Op : OPERATION; Scan_Start : NATURAL; Scan_End : NATURAL; begin -- Adjust if Text'Length > 0 then case Text(Text'First) is when '+' => Op := INCREMENT; Scan_Start := Text'First + 1; when '-' => Op := DECREMENT; Scan_Start := Text'First + 1; when others => Op := SET; Scan_Start := Text'First; end case; Scan_End := Text'Last; for I in Scan_Start .. Text'Last loop if Text(I) <= ' ' then Scan_End := I - 1; exit; end if; end loop; Temp := To_Nat(Text(Scan_Start .. Scan_End)); case Op is when INCREMENT => Result := Original_Value + Temp; when DECREMENT => if Original_Value >= Temp then Result := Original_Value - Temp; else Result := 0; end if; when SET => Result := Temp; end case; end if; return Result; end Adjust; -- .................................. -- . . -- . Identify . BODY -- . . -- .................................. function Identify ( Item : in STRING ) return Command_Id is --| Notes (none) Target_Command : Command_Text := Convert(Item); Result : Command_Id := Unknown; begin -- Identify for I in Cl'range loop if Target_Command = Cl(I).Name then Result := Cl(I).Id; exit; end if; end loop; return Result; exception when others => Error_Log.Write_Error(Error_Internal_Identify); return Unknown; end Identify; -- .................................. -- . . -- . Process . BODY -- . . -- .................................. procedure Process ( Id : in Command_Id; Line_Tail : in STRING; Target : in out Formatted_Output_File.File; Input_File_Id : in out Input_File.File_Type ) is --| Notes (none) Temp : NATURAL; Temp1 : NATURAL; Old_Value : NATURAL; Line_To_Write : STRING (1 .. Ltw_Length); Ltw_Last : NATURAL; Mid : Macro.Macro_Id; Mid_Read : Macro.Macro_Id; Mstatus : Macro.Macro_Status; Inline : STRING (1 .. 200); Inlast : NATURAL; Inline_Verb : STRING (1 .. 200); Inlast_Verb : NATURAL; Inline_Tail : STRING (1 .. 200); Inlast_Tail : NATURAL; Hf_Left : STRING (1 .. 100); Hf_Llast : NATURAL; Hf_Center : STRING (1 .. 100); Hf_Clast : NATURAL; Hf_Right : STRING (1 .. 100); Hf_Rlast : NATURAL; Hf_Line : Fof.Header_Footer_Line; type HF_TYPE is ( FOOTER_LINE, HEADER_LINE ); Command_Name : Command_Symbols.Command_Text; -- .................................. -- . . -- . Process.Parse_Hf . SPEC & BODY -- . . -- .................................. function Parse_Hf ( Line : in STRING; Kind : in HF_TYPE ) return Fof.Header_Footer_Line is --| Purpose --| Parse_Hf accepts a Line of the form /--/--/--/ or #/--/--/--/ --| and places the three parts into Hf_Left, Hf_Center, and Hf_Right. --| If the # is present, it returns the #; else, it returns the default --| value for the # based on Kind. --| --| Exceptions (none) --| Notes (none) Default_Header_Line : Fof.Header_Footer_Line := 1; Default_Footer_Line : Fof.Header_Footer_Line := 2; Hf_Line_Number : Fof.Header_Footer_Line; Temp : NATURAL; Fof_Kind : Fof.Page_Attribute; Start : NATURAL := Line'First; Delimiter : CHARACTER; -- .................................. -- . . -- . Process.Parse_Hf.Sub_Parse . SPEC & BODY -- . . -- .................................. procedure Sub_Parse ( Item : in out STRING; Last : out NATURAL ) is --| Purpose --| Sub_Parse parses Line starting at Start until Delimiter --| or Line'Last is encountered. It places the parsed-out --| string into Item and returns the index of the last character. --| --| Exceptions (none) --| Notes (none) Item_Index : NATURAL := Item'First - 1; Stop : NATURAL := Line'Last + 1; begin -- Sub_Parse if Start <= Line'Last then for I in Start .. Line'Last loop if Line(I) = Delimiter then Stop := I; exit; else Item_Index := Item_Index + 1; Item(Item_Index) := Line(I); end if; end loop; Start := Stop + 1; end if; while Item_Index >= Item'First loop -- remove trailing white space exit when Item(Item_Index) > ' '; Item_Index := Item_Index - 1; end loop; Last := Item_Index; end Sub_Parse; begin -- Parse_Hf case Kind is when HEADER_LINE => Hf_Line_Number := Default_Header_Line; Fof_Kind := Fof.Header_Lines; when FOOTER_LINE => Hf_Line_Number := Default_Footer_Line; Fof_Kind := Fof.Footer_Lines; end case; if Line'Length > 0 then if (Line(Start) >= '0') and (Line(Start) <= '9') then Temp := To_Nat(Line(Start .. Start)); if (Temp > 0) and (Temp <= Fof.Get_Page_Attribute(Target, Fof_Kind)) then Hf_Line_Number := Fof.Header_Footer_Line(Temp); else Error_Log.Write_Error(Error_Hf_Lines); end if; Start := Start + 1; end if; Temp := Start; Start := Line'Last + 1; for I in Temp .. Line'Last loop if Line(I) > ' ' then Start := I; exit; end if; end loop; if Start <= Line'Last then Delimiter := Line(Start); Start := Start + 1; Sub_Parse(Hf_Left, Hf_Llast); Sub_Parse(Hf_Center, Hf_Clast); Sub_Parse(Hf_Right, Hf_Rlast); end if; else Hf_Llast := 0; Hf_Clast := 0; Hf_Rlast := 0; end if; return Hf_Line_Number; end Parse_Hf; -- .................................. -- . . -- . Process.Interpret_Write . SPEC & BODY -- . . -- .................................. procedure Interpret_Write ( In_String : in STRING; Out_String : out STRING; Out_Last : out NATURAL ) is --| Purpose --| Interpret_Write interprets control and escape characters --| from In_String, placing the result into Out_String. --| Interpret_Write is only called by the WRITE command --| processing section of code. --| --| Exceptions (none) --| Notes (none) O_Index : NATURAL := Out_String'First; type STATE_TYPE is ( IN_CONTROL, IN_ESCAPE, IN_TEXT ); Current_State : STATE_TYPE := IN_TEXT; begin -- Interpret_Write for I in In_String'range loop case Current_State is when IN_TEXT => case In_String(I) is when '^' => Current_State := IN_CONTROL; when '\' => Current_State := IN_ESCAPE; when others => if O_Index <= Out_String'Last then Out_String(O_Index) := In_String(I); O_Index := O_Index + 1; else Error_Log.Write_Error(Error_Write); exit; end if; end case; when IN_CONTROL => Temp := CHARACTER'Pos(In_String(I)) - CHARACTER'Pos('@'); if O_Index <= Out_String'Last then Out_String(O_Index) := CHARACTER'Val(Temp); O_Index := O_Index + 1; else Error_Log.Write_Error(Error_Write); exit; end if; Current_State := IN_TEXT; when IN_ESCAPE => if O_Index <= Out_String'Last then case In_String(I) is when 'b' => Out_String(O_Index) := Ascii.Bs; when 'd' => Out_String(O_Index) := Ascii.Del; when 'e' => Out_String(O_Index) := Ascii.Esc; when 'n' => Out_String(O_Index) := Ascii.Lf; when 'r' => Out_String(O_Index) := Ascii.Cr; when 't' => Out_String(O_Index) := Ascii.Ht; when others => Out_String(O_Index) := In_String(I); end case; O_Index := O_Index + 1; else Error_Log.Write_Error(Error_Write); exit; end if; Current_State := IN_TEXT; end case; end loop; Out_Last := O_Index - 1; end Interpret_Write; -- .................................. -- . . -- . Process.Check_Margins . SPEC & BODY -- . . -- .................................. function Check_Margins return BOOLEAN is --| Purpose --| Check_Margins is a common routine for checking to ensure that --| the margins are OK before a change is fully put into effect. --| Return TRUE if margins are OK. --| --| Exceptions (none) --| Notes (none) Result : BOOLEAN; begin -- Check_Margins Result := (Fof.Get_Page_Attribute(Target, Fof.Left_Margin) + Fof.Get_Page_Attribute(Target, Fof.Left_Indent)) < (Fof.Get_Page_Attribute(Target, Fof.Right_Margin) - Fof.Get_Page_Attribute(Target, Fof.Right_Indent)); if not Result then Error_Log.Write_Error(Error_Margin); end if; return Result; end Check_Margins; -- .................................. -- . . -- . Process.Add_Line_To_Macro . SPEC & BODY -- . . -- .................................. function Add_Line_To_Macro return BOOLEAN is --| Purpose --| In the environment of Process, Add_Line_To_Macro adds the line --| Inline(1..Inlast) as the next line in the macro. If this line --| is itself a macro, then its macro definition is added. --| --| Exceptions (none) --| Notes --| Variables Process.Inline and Process.Inlast are accessed. --| Variables Process.Inline_Verb, Process.Inline_Tail, --| Process.Inlast_Verb, and Process.Inlast_Tail are altered. Continue : BOOLEAN := true; begin -- Add_Line_To_Macro if Inline(1) = Variable.Cc then -- Dot command Parse(Inline(2 .. Inlast), Inline_Verb, Inline_Tail, Inlast_Verb, Inlast_Tail); if Command.Identify(Inline_Verb(1 .. Inlast_Verb)) = Stop_Macro then -- End of macro encountered Continue := false; else -- Inside macro if Command.Identify(Inline_Verb(1 .. Inlast_Verb)) = Unknown then -- Not a normal command if Macro.Locate(Inline_Verb(1 .. Inlast_Verb)) = Macro.Ok then Macro.Open(Inline_Verb(1 .. Inlast_Verb), Mid_Read, Mstatus); while not Macro.Is_Empty(Mid_Read) loop Macro.Read(Mid_Read, Inline, Inlast); Macro.Write(Mid, Inline(1 .. Inlast)); end loop; Macro.Close(Mid_Read); else Error_Log.Write_Error(Error_Macro_Unknown_Command); end if; else -- Normal command Macro.Write(Mid, Inline(1 .. Inlast)); end if; end if; else -- Not dot command Macro.Write(Mid, Inline(1 .. Inlast)); end if; return Continue; end Add_Line_To_Macro; -- .................................. -- . . -- . Process.Fill_Command_Name . SPEC & BODY -- . . -- .................................. procedure Fill_Command_Name ( What : in STRING ) is --| Purpose --| Fill_Command_Name places the string in What into the variable --| Command_Name, space-filling if necessary. --| --| Exceptions (none) --| Notes --| Variable Process.Command_Name is altered Last : NATURAL; Index : NATURAL := Command_Name'First; begin -- Fill_Command_Name Command_Name := (others => ' '); if What'Length <= Command_Name'Length then Last := What'Last; else Last := What'First + Command_Name'Length - 1; end if; for I in What'First .. Last loop Command_Name(Index) := What(I); Index := Index + 1; end loop; end Fill_Command_Name; begin -- Process case Id is when Auto_Paragraph => Variable.Set_Auto_Paragraph(true); when Bold => if Is_Bolding then if Line_Tail'Length > 0 then if Line_Tail(1) = 'o' then if Line_Tail(2) = 'n' then Fof.Set_Line_Attribute(Target, Fof.Bold, Fof.On); else Fof.Set_Line_Attribute(Target, Fof.Bold, Fof.Off); end if; else Temp := To_Nat(Line_Tail); if Temp > 0 then Variable.Set_Bold_Count(Temp); Fof.Set_Line_Attribute(Target, Fof.Bold, Fof.On); end if; end if; else Variable.Set_Bold_Count(1); Fof.Set_Line_Attribute(Target, Fof.Bold, Fof.On); end if; end if; when Break => Fof.Break_Line(Target); when Center => Fof.Break_Line(Target); if Line_Tail'Length > 0 then if Line_Tail(1) = 'o' then if Line_Tail(2) = 'n' then Fof.Set_Line_Attribute(Target, Fof.Center, Fof.On); else Fof.Set_Line_Attribute(Target, Fof.Center, Fof.Off); end if; else Temp := To_Nat(Line_Tail); if Temp > 0 then Variable.Set_Center_Count(Temp); Fof.Set_Line_Attribute(Target, Fof.Center, Fof.On); else Fof.Set_Line_Attribute(Target, Fof.Center, Fof.Off); end if; end if; else Variable.Set_Center_Count(1); Fof.Set_Line_Attribute(Target, Fof.Center, Fof.On); end if; when Comment => null; when Console_Message => Console.Put_Line(Line_Tail); when Contents_Select => if Line_Tail'Length > 0 then Temp := To_Nat(Line_Tail); if Temp <= 5 then Contents.Select_Table(Temp); else Error_Log.Write_Warning(Warning_Contents_Number); Contents.Select_Table(0); end if; else Contents.Select_Table(0); end if; when Disable_Bolding => Is_Bolding := false; when Enable_Bolding => Is_Bolding := true; when Enter_Contents => Fof.Break_Line(Target); if Line_Tail'Length > 0 then if Line_Tail(1) in '0' .. '9' then Parse(Line_Tail, Inline_Verb, Inline_Tail, Inlast_Verb, Inlast_Tail); Last_Contents_Indent := To_Nat(Inline_Verb(1 .. Inlast_Verb)); Contents.Add_Line(Last_Contents_Indent, Inline_Tail(1 .. Inlast_Tail), Fof.Current_Page(Target)); else Contents.Add_Line(Last_Contents_Indent, Line_Tail, Fof.Current_Page(Target)); end if; else Contents.Add_Line(0, "", Fof.Current_Page(Target)); end if; when Environment_Pop => Fof.Break_Line(Target); Environment.Pop(Target, Is_Bolding, Is_Underlining); when Environment_Push => Fof.Break_Line(Target); Environment.Push(Target, Is_Bolding, Is_Underlining); when Fill => Fof.Break_Line(Target); Fof.Set_Line_Attribute(Target, Fof.Fill, Fof.On); when Footer => Hf_Line := Parse_Hf(Line_Tail, FOOTER_LINE); if Hf_Line > 0 then Fof.Set_Footer_Line(Target, Fof.All_Pages, Hf_Line, Hf_Left(1 .. Hf_Llast), Hf_Center(1 .. Hf_Clast), Hf_Right(1 .. Hf_Rlast)); else Error_Log.Write_Error(Error_Hf_Lines); end if; when Footer_Even => Hf_Line := Parse_Hf(Line_Tail, FOOTER_LINE); if Hf_Line > 0 then Fof.Set_Footer_Line(Target, Fof.Even_Pages, Hf_Line, Hf_Left(1 .. Hf_Llast), Hf_Center(1 .. Hf_Clast), Hf_Right(1 .. Hf_Rlast)); else Error_Log.Write_Error(Error_Hf_Lines); end if; when Footer_Odd => Hf_Line := Parse_Hf(Line_Tail, FOOTER_LINE); if Hf_Line > 0 then Fof.Set_Footer_Line(Target, Fof.Odd_Pages, Hf_Line, Hf_Left(1 .. Hf_Llast), Hf_Center(1 .. Hf_Clast), Hf_Right(1 .. Hf_Rlast)); else Error_Log.Write_Error(Error_Hf_Lines); end if; when Header => Hf_Line := Parse_Hf(Line_Tail, HEADER_LINE); if Hf_Line > 0 then Fof.Set_Header_Line(Target, Fof.All_Pages, Hf_Line, Hf_Left(1 .. Hf_Llast), Hf_Center(1 .. Hf_Clast), Hf_Right(1 .. Hf_Rlast)); else Error_Log.Write_Error(Error_Hf_Lines); end if; when Header_Even => Hf_Line := Parse_Hf(Line_Tail, HEADER_LINE); if Hf_Line > 0 then Fof.Set_Header_Line(Target, Fof.Even_Pages, Hf_Line, Hf_Left(1 .. Hf_Llast), Hf_Center(1 .. Hf_Clast), Hf_Right(1 .. Hf_Rlast)); else Error_Log.Write_Error(Error_Hf_Lines); end if; when Header_Odd => Hf_Line := Parse_Hf(Line_Tail, HEADER_LINE); if Hf_Line > 0 then Fof.Set_Header_Line(Target, Fof.Odd_Pages, Hf_Line, Hf_Left(1 .. Hf_Llast), Hf_Center(1 .. Hf_Clast), Hf_Right(1 .. Hf_Rlast)); else Error_Log.Write_Error(Error_Hf_Lines); end if; when Include => if Line_Tail'Length > 0 then if Word_Processor.Process_Source_File(Line_Tail) = Word_Processor.Not_Ok then Error_Log.Write_Error(Error_Include & Line_Tail); end if; else Error_Log.Write_Error(Error_Include & Line_Tail); end if; when Index_Entry => if Line_Tail'Length > 0 then if not Index_Is_Open then begin Temp := Fof.Get_Page_Attribute(Target, Fof.Right_Margin) - Fof.Get_Page_Attribute(Target, Fof.Left_Margin) + 1; Temp1 := Fof.Get_Page_Attribute(Target, Fof.Total_Lines) - (Fof.Get_Page_Attribute(Target, Fof.Header_Lines) + Fof.Get_Page_Attribute(Target, Fof.Footer_Lines) + Fof.Get_Page_Attribute(Target, Fof.Top_Margin) + Fof.Get_Page_Attribute(Target, Fof.Bottom_Margin)); Index.Create(Index_File_Name, Index_Line_Length, Temp, Temp1); Index_Is_Open := true; exception when others => Error_Log.Write_Error(Error_Index_File_Create); end; end if; if Index_Is_Open then begin Index.Add_Entry(Line_Tail, Fof.Current_Page(Target)); exception when others => null; end; end if; end if; when Index_Length => if Line_Tail'Length > 0 then Temp := To_Nat(Line_Tail); if Temp > 0 then Index_Line_Length := Temp; end if; end if; when Justify => Fof.Break_Line(Target); Fof.Set_Line_Attribute(Target, Fof.Justify, Fof.On); when Left_Indent => Fof.Break_Line(Target); Old_Value := Fof.Get_Page_Attribute(Target, Fof.Left_Indent); Temp := Adjust(Old_Value, Line_Tail); Fof.Set_Page_Attribute(Target, Fof.Left_Indent, Temp); if not Check_Margins then Fof.Set_Page_Attribute(Target, Fof.Left_Indent, Old_Value); end if; when Left_Margin => Fof.Break_Line(Target); Old_Value := Fof.Get_Page_Attribute(Target, Fof.Left_Margin); Temp := Adjust(Old_Value, Line_Tail); if Temp = 0 then Temp := 1; end if; Fof.Set_Page_Attribute(Target, Fof.Left_Margin, Temp); if not Check_Margins then Fof.Set_Page_Attribute(Target, Fof.Left_Margin, Old_Value); end if; when Lex => if Line_Tail'Length > 0 then Parse(Line_Tail, Inline_Verb, Inline_Tail, Inlast_Verb, Inlast_Tail); Fill_Command_Name(Inline_Verb(1 .. Inlast_Verb)); Temp := Cl'Last + 1; for I in Cl'range loop if Command_Name = Cl(I).Name then Temp := I; exit; end if; end loop; if Temp > Cl'Last then Error_Log.Write_Error(Error_Unknown); else Fill_Command_Name(Inline_Tail(1 .. Inlast_Tail)); Cl(Temp).Name := Command_Name; end if; else Error_Log.Write_Error(Error_Lex); end if; when Line_Spacing => if Line_Tail'Length > 0 then Temp := Fof.Get_Page_Attribute(Target, Fof.Line_Spacing) + 1; Temp := Adjust(Temp, Line_Tail) - 1; Fof.Set_Page_Attribute(Target, Fof.Line_Spacing, Temp); else Fof.Set_Page_Attribute(Target, Fof.Line_Spacing, Fof. Page_Attribute_Defaults(Fof.Line_Spacing)); end if; when Nl_Bottom => if Line_Tail'Length > 0 then Temp := To_Nat(Line_Tail); Fof.Set_Page_Attribute(Target, Fof.Bottom_Margin, Temp); else Fof.Set_Page_Attribute(Target, Fof.Bottom_Margin, Default_Bottom); end if; when Nl_Footer => if Line_Tail'Length > 0 then Temp := To_Nat(Line_Tail); if Temp > Fof.Maximum_Number_Of_Header_Footer_Lines then Error_Log.Write_Error(Error_Hf_Lines); else Fof.Set_Page_Attribute(Target, Fof.Footer_Lines, Temp); for I in 1 .. Fof.Header_Footer_Line(Temp) loop Fof.Set_Footer_Line(Target, Fof.All_Pages, I, "", "", ""); end loop; end if; else Fof.Set_Page_Attribute(Target, Fof.Footer_Lines, Default_Footer); end if; when Nl_Header => if Line_Tail'Length > 0 then Temp := To_Nat(Line_Tail); if Temp > Fof.Maximum_Number_Of_Header_Footer_Lines then Error_Log.Write_Error(Error_Hf_Lines); else Fof.Set_Page_Attribute(Target, Fof.Header_Lines, Temp); for I in 1 .. Fof.Header_Footer_Line(Temp) loop Fof.Set_Header_Line(Target, Fof.All_Pages, I, "", "", ""); end loop; end if; else Fof.Set_Page_Attribute(Target, Fof.Header_Lines, Default_Header); end if; when Nl_Top => if Line_Tail'Length > 0 then Temp := To_Nat(Line_Tail); Fof.Set_Page_Attribute(Target, Fof.Top_Margin, Temp); else Fof.Set_Page_Attribute(Target, Fof.Top_Margin, Default_Top); end if; when No_Auto_Paragraph => Variable.Set_Auto_Paragraph(false); when No_Fill => Fof.Break_Line(Target); Fof.Set_Line_Attribute(Target, Fof.Fill, Fof.Off); when No_Justify => Fof.Break_Line(Target); Fof.Set_Line_Attribute(Target, Fof.Justify, Fof.Off); when No_Paging => Fof.Break_Line(Target); Fof.Set_Line_Attribute(Target, Fof.Paging, Fof.Off); when Number_Register => if Line_Tail'Length > 0 then Parse(Line_Tail, Inline_Verb, Inline_Tail, Inlast_Verb, Inlast_Tail); if Inlast_Verb > 0 then if Inline_Verb(1) in Variable.Nreg then Temp := Variable.Nr(Inline_Verb(1)); Variable.Set_Nr(Inline_Verb(1), Adjust(Temp, Inline_Tail(1 .. Inlast_Tail))); else Error_Log.Write_Error(Error_Number_Register & "(reg ID)"); end if; else Error_Log.Write_Error(Error_Number_Register & "(argument)"); end if; else Error_Log.Write_Error(Error_Number_Register & "(after .nr)"); end if; when Offset => Fof.Break_Line(Target); if Line_Tail'Length > 0 then Temp := Fof.Get_Page_Attribute(Target, Fof.Page_Offset); Temp := Adjust(Temp, Line_Tail); Fof.Set_Page_Attribute(Target, Fof.Page_Offset, Temp); else Fof.Set_Page_Attribute(Target, Fof.Page_Offset, 0); end if; when Page => if Line_Tail'Length > 0 then Temp := To_Nat(Line_Tail); if Temp = 0 then Temp := 1; end if; Fof.Break_Page(Target, Fof.Page_Number(Temp)); else Fof.Break_Page(Target); end if; when Page_Number_Format => if Line_Tail'Length > 0 then Parse(Line_Tail, Inline_Verb, Inline_Tail, Inlast_Verb, Inlast_Tail); case Inline_Verb(1) is when 'a' => Fof.Set_Page_Number_Format(Target, Fof.Arabic, Inline_Tail(1..Inlast_Tail)); when 'l' => Fof.Set_Page_Number_Format(Target, Fof.Lower_Roman, Inline_Tail(1..Inlast_Tail)); when 'u' => Fof.Set_Page_Number_Format(Target, Fof.Upper_Roman, Inline_Tail(1..Inlast_Tail)); when others => Error_Log.Write_Error(Error_Page_Number_Format); end case; else Fof.Set_Page_Number_Format(Target, Fof.Arabic, ""); end if; when Page_Size => if Line_Tail'Length > 0 then Temp := Fof.Get_Page_Attribute(Target, Fof.Total_Lines); Temp := Adjust(Temp, Line_Tail); Fof.Set_Page_Attribute(Target, Fof.Total_Lines, Temp); else Fof.Set_Page_Attribute(Target, Fof.Total_Lines, Fof. Page_Attribute_Defaults(Fof.Total_Lines)); end if; when Paging => Fof.Break_Line(Target); Fof.Set_Line_Attribute(Target, Fof.Paging, Fof.On); when Print_Contents => Fof.Break_Line(Target); if Line_Tail'Length > 0 then Contents.Print(Target, To_Nat(Line_Tail)); else Contents.Print(Target, Default_Contents_Indentation); end if; when Right_Indent => Fof.Break_Line(Target); Old_Value := Fof.Get_Page_Attribute(Target, Fof.Right_Indent); Temp := Adjust(Old_Value, Line_Tail); Fof.Set_Page_Attribute(Target, Fof.Right_Indent, Temp); if not Check_Margins then Fof.Set_Page_Attribute(Target, Fof.Right_Indent, Old_Value); end if; when Right_Margin => Fof.Break_Line(Target); Old_Value := Fof.Get_Page_Attribute(Target, Fof.Right_Margin); Temp := Adjust(Old_Value, Line_Tail); Fof.Set_Page_Attribute(Target, Fof.Right_Margin, Temp); if not Check_Margins then Fof.Set_Page_Attribute(Target, Fof.Right_Margin, Old_Value); end if; when Set_Cchar => if Line_Tail'Length > 0 then Variable.Set_Cc(Line_Tail(Line_Tail'First)); else Variable.Set_Cc(Variable.Default_Cc); end if; when Set_Echar => if Line_Tail'Length > 0 then Variable.Set_Ec(Line_Tail(Line_Tail'First)); else Variable.Set_Ec(Variable.Default_Ec); end if; when Set_Fchar => if Line_Tail'Length > 0 then Variable.Set_Fc(Line_Tail(Line_Tail'First)); else Variable.Set_Fc(Variable.Default_Fc); end if; when Skip => Fof.Break_Line(Target); if Line_Tail'Length > 0 then Fof.Skip(Target, Fof.Line_Number(To_Nat(Line_Tail))); else Fof.Skip(Target, 1); end if; when Space_To => Fof.Break_Line(Target); if Line_Tail'Length > 0 then case Line_Tail(1) is when '-' => Temp := Fof.Get_Page_Attribute(Target, Fof.Total_Lines); Temp := Temp - Fof.Get_Page_Attribute(Target, Fof.Bottom_Margin); Temp := Temp - Fof.Get_Page_Attribute(Target, Fof.Footer_Lines); Temp := Adjust(Temp, Line_Tail); when '+' => Temp := Fof.Get_Page_Attribute(Target, Fof.Top_Margin) + 1; Temp := Temp + Fof.Get_Page_Attribute(Target, Fof.Header_Lines); Temp := Adjust(Temp, Line_Tail); when others => Temp := To_Nat(Line_Tail); end case; if Temp < NATURAL(Fof.Current_Line(Target)) then Error_Log.Write_Error(Error_Spaceto); else Temp := Temp - NATURAL(Fof.Current_Line(Target)); if Temp > 0 then Old_Value := Fof.Get_Page_Attribute(Target, Fof.Line_Spacing); Fof.Set_Page_Attribute(Target, Fof.Line_Spacing, 0); Fof.Skip(Target, Fof.Line_Number(Temp)); Fof.Set_Page_Attribute(Target, Fof.Line_Spacing, Old_Value); end if; end if; end if; when Start_Macro => if Line_Tail'Length > 0 then Macro.Create(Line_Tail, Mid, Mstatus); if Mstatus = Macro.Ok then while not Input_File.End_Of_File(Input_File_Id) loop Input_File.Get_Line(Input_File_Id, Inline, Inlast); Variable.Increment_Line_Number; if Inlast > 0 then exit when not Add_Line_To_Macro; end if; end loop; Macro.Close(Mid); else Error_Log.Write_Error(Error_Macro); end if; else Error_Log.Write_Error(Error_Macro); end if; when Stop_Macro => Error_Log.Write_Error(Error_Macro_End); when Temporary_Indent => Fof.Break_Line(Target); if Line_Tail'Length > 0 then Temp := Fof.Get_Page_Attribute(Target, Fof.Left_Margin) + Fof.Get_Page_Attribute(Target, Fof.Left_Indent); Temp := Adjust(Temp, Line_Tail); if Temp > 0 then Fof.Set_Page_Attribute(Target, Fof.Temp_Indent, Temp); else Error_Log.Write_Error(Error_Indent); end if; end if; when Test_Page => if Line_Tail'Length > 0 then Temp := To_Nat(Line_Tail); if Temp > 0 then if not Fof.Test_Page(Target, Fof.Line_Number(Temp)) then Fof.Break_Page(Target); end if; end if; end if; when Underline => if Is_Underlining then if Line_Tail'Length > 0 then if Line_Tail(1) = 'o' then if Line_Tail(2) = 'n' then Fof.Set_Line_Attribute(Target, Fof.Underline, Fof.On); else Fof.Set_Line_Attribute(Target, Fof.Underline, Fof.Off); end if; else Temp := To_Nat(Line_Tail); if Temp > 0 then Variable.Set_Underline_Count(Temp); Fof.Set_Line_Attribute(Target, Fof.Underline, Fof.On); end if; end if; else Variable.Set_Underline_Count(1); Fof.Set_Line_Attribute(Target, Fof.Underline, Fof.On); end if; end if; when Underline_Mode => if Line_Tail'Length > 0 then case Line_Tail(1) is when 'a' => Fof.Set_Line_Attribute(Target, Fof.Underline_Punct, Fof.On); when others => Fof.Set_Line_Attribute(Target, Fof.Underline_Punct, Fof.Off); end case; else Fof.Set_Line_Attribute(Target, Fof.Underline_Punct, Fof.Off); end if; when Disable_Underlining => Is_Underlining := false; when Enable_Underlining => Is_Underlining := true; when Variable_Get => if Line_Tail'Length > 0 then Parse(Line_Tail, Inline_Verb, Inline_Tail, Inlast_Verb, Inlast_Tail); if Inlast_Tail > 0 then Console.Put(Inline_Tail(1 .. Inlast_Tail)); else Console.Put(Inline_Verb(1 .. Inlast_Verb) & "> "); end if; Console.Get_Line(Inline_Tail, Inlast_Tail); Variable.Set_Var(Inline_Verb(1 .. Inlast_Verb), Inline_Tail(1 .. Inlast_Tail)); else Error_Log.Write_Error(Error_Variable_Set); end if; when Variable_Set => if Line_Tail'Length > 0 then Parse(Line_Tail, Inline_Verb, Inline_Tail, Inlast_Verb, Inlast_Tail); Variable.Set_Var(Inline_Verb(1 .. Inlast_Verb), Inline_Tail(1 .. Inlast_Tail)); else Error_Log.Write_Error(Error_Variable_Set); end if; when Write => if Line_Tail'Length > 0 then Interpret_Write(Line_Tail, Line_To_Write, Ltw_Last); Fof.Put_Invisible_Word(Target, Line_To_Write(1 .. Ltw_Last)); end if; when Unknown => Error_Log.Write_Error(Error_Unknown); end case; exception when others => Error_Log.Write_Error(Error_Internal_Process); end Process; -- .................................. -- . . -- . Disable_Bolding . BODY -- . . -- .................................. procedure Disable_Bolding is --| Notes (none) begin -- Disable_Bolding Is_Bolding := false; end Disable_Bolding; -- .................................. -- . . -- . Disable_Underlining . BODY -- . . -- .................................. procedure Disable_Underlining is --| Notes (none) begin -- Disable_Underlining Is_Underlining := false; end Disable_Underlining; end Command; --:::::::::: --cnt_body.a --:::::::::: -- ********************************** -- * * -- * Contents * BODY -- * * -- ********************************** with Command_Symbols; with Error_Log; with Input_File; with Output_File; package body Contents is --| Notes (none) --| --| Modifications --| 08/16/89 Rick Conn Initial Version Current_Table : Table_Number := 0; Current_Table_File : STRING (1 .. 8) := "cnt0.cnt"; Current_Number_Position : constant := 4; type TABLE_TYPE is record File_Id : Output_File.File_Type; Is_Open : BOOLEAN := false; end record; type TABLE_ARRAY is array (Table_Number) of TABLE_TYPE; Table : TABLE_ARRAY; package Fof renames Formatted_Output_File; use Command_Symbols; -- .................................. -- . . -- . Select_Table . BODY -- . . -- .................................. procedure Select_Table ( Which_Table : in Table_Number ) is --| Notes (none) begin -- Select_Table Current_Table := Which_Table; Current_Table_File(Current_Number_Position) := CHARACTER'Val(Current_Table + CHARACTER'Pos('0')); end Select_Table; -- .................................. -- . . -- . Add_Line . BODY -- . . -- .................................. procedure Add_Line ( Level : in NATURAL; Line : in STRING; Page_Number : in STRING ) is --| Notes (none) begin -- Add_Line if not Table(Current_Table).Is_Open then Output_File.Create(Table(Current_Table).File_Id, Current_Table_File); Table(Current_Table).Is_Open := true; end if; Output_File.Put_Line(Table(Current_Table).File_Id, NATURAL'Image(Level)); Output_File.Put_Line(Table(Current_Table).File_Id, Line); Output_File.Put_Line(Table(Current_Table).File_Id, Page_Number); exception -- Add_Line -- Add_Line when others => Error_Log.Write_Error(Error_Internal_Add_Line); end Add_Line; -- .................................. -- . . -- . Print . BODY -- . . -- .................................. procedure Print ( Target : in Formatted_Output_File.File; Spaces_Per_Level : in NATURAL ) is --| Notes (none) Old_Fill : Fof.Off_On; Cline : STRING (1 .. 200); Cline_Last : NATURAL; Line : STRING (1 .. 200); Line_Last : NATURAL; Clevel : NATURAL; Cpage : STRING (1 .. 200); Cpage_Last : NATURAL; Start : NATURAL; Dummy : BOOLEAN; Input_File_Id : Input_File.File_Type; -- .................................. -- . . -- . Print.Build_Line . SPEC & BODY -- . . -- .................................. procedure Build_Line ( Level : in NATURAL; Line : in STRING; Page_Number : in STRING ) is --| Purpose --| Build_Line builds the table of contents line into the Cline string, --| setting Cline_Last to the index of the last character. --| --| Exceptions (none) --| Notes (none) Left : NATURAL := Spaces_Per_Level * Level + 1; Right : NATURAL := Fof.Get_Page_Attribute(Target, Fof.Right_Margin) - Fof.Get_Page_Attribute(Target, Fof.Page_Offset) - Fof.Get_Page_Attribute(Target, Fof.Left_Margin) + 1; Start : NATURAL := Left + Line'Length; begin -- Build_Line if Line'Length > 0 then Cline_Last := Left - 1; Cline(1 .. Right) := (others => ' '); Cline(Cline_Last + 1 .. Cline_Last + Line'Length) := Line; if Cline_Last + Line'Length > Right - Page_Number'Length then Error_Log.Write_Warning(Warning_Contents_Line_Truncation); end if; if (Start / 2) * 2 /= Start then Start := Start + 1; end if; Start := Start + 1; for I in Start .. Right loop Cline(I) := '.'; end loop; Cline(Right - Page_Number'Length .. Right) := " " & Page_Number; Cline_Last := Right; else Cline_Last := 0; end if; end Build_Line; begin -- Print Fof.Break_Line(Target); Old_Fill := Fof.Get_Line_Attribute(Target, Fof.Fill); Fof.Set_Line_Attribute(Target, Fof.Fill, Fof.Off); if Table(Current_Table).Is_Open then Output_File.Close(Table(Current_Table).File_Id); Table(Current_Table).Is_Open := false; Input_File.Open(Input_File_Id, Current_Table_File); while not Input_File.End_Of_File(Input_File_Id) loop Input_File.Get_Line(Input_File_Id, Cline, Cline_Last); Start := Cline_Last + 1; for I in 1 .. Cline_Last loop if Cline(I) > ' ' then Start := I; exit; end if; end loop; if Start <= Cline_Last then begin Clevel := NATURAL'Value(Cline(Start .. Cline_Last)); exception when others => Clevel := 0; end; else Clevel := 0; end if; Input_File.Get_Line(Input_File_Id, Line, Line_Last); Input_File.Get_Line(Input_File_Id, Cpage, Cpage_Last); Build_Line(Clevel, Line(1 .. Line_Last), Cpage(1 .. Cpage_Last)); Fof.Put_Line(Target, Cline(1 .. Cline_Last)); end loop; Input_File.Close(Input_File_Id); Dummy := Output_File.Delete(Current_Table_File); else Error_Log.Write_Warning(Warning_Table_Empty); end if; Fof.Set_Line_Attribute(Target, Fof.Fill, Old_Fill); exception -- Print when others => Error_Log.Write_Error(Error_Internal_Print); end Print; end Contents; --:::::::::: --cot_body.a --:::::::::: -- ********************************** -- * * -- * Console * BODY -- * * -- ********************************** with Text_IO; package body Console is --| Notes (none) --| --| Modifications --| 08/16/89 Rick Conn Initial Version -- .................................. -- . . -- . Put . BODY -- . . -- .................................. procedure Put ( Item : in CHARACTER ) is --| Notes (none) begin -- Put Text_IO.Put(Item); end Put; -- .................................. -- . . -- . Put . BODY -- . . -- .................................. procedure Put ( Item : in STRING ) is --| Notes (none) begin -- Put Text_IO.Put(Item); end Put; -- .................................. -- . . -- . Put_Line . BODY -- . . -- .................................. procedure Put_Line ( Item : in STRING ) is --| Notes (none) begin -- Put_Line Text_IO.Put_Line(Item); end Put_Line; -- .................................. -- . . -- . New_Line . BODY -- . . -- .................................. procedure New_Line is --| Notes (none) begin -- New_Line Text_IO.New_Line; end New_Line; -- .................................. -- . . -- . Get_Line . BODY -- . . -- .................................. procedure Get_Line ( Item : out STRING; Last : out NATURAL ) is --| Notes (none) begin -- Get_Line Text_IO.Get_Line(Item, Last); end Get_Line; end Console; --:::::::::: --env_body.a --:::::::::: -- ********************************** -- * * -- * Environment * BODY -- * * -- ********************************** with Command_Symbols; with Error_Log; with Variable; package body Environment is --| Notes (none) --| --| Modifications --| 08/16/89 Rick Conn Initial Version --| 02/26/90 Rick Conn Add Set_Underlining to Pop/Push Number_Of_Stack_Elements : NATURAL := 0; type PAGE_LIST is array (Formatted_Output_File.Page_Attribute) of NATURAL; type LINE_LIST is array (Formatted_Output_File.Line_Attribute) of Formatted_Output_File.Off_On; type STACK_ELEMENT; type STACK_ELEMENT_POINTER is access STACK_ELEMENT; type STACK_ELEMENT is record Pages : PAGE_LIST; Lines : LINE_LIST; Cc_Val : CHARACTER; Ec_Val : CHARACTER; Fc_Val : CHARACTER; Auto_Paragraph : BOOLEAN; Bolding : BOOLEAN; Underlining : BOOLEAN; Bold_Count : NATURAL; Center_Count : NATURAL; Ul_Count : NATURAL; Next : STACK_ELEMENT_POINTER := null; Last : STACK_ELEMENT_POINTER := null; end record; Current : STACK_ELEMENT_POINTER := null; package Fof renames Formatted_Output_File; use Command_Symbols; use Formatted_Output_File; -- .................................. -- . . -- . Pop . BODY -- . . -- .................................. procedure Pop ( Item : in Formatted_Output_File.File; Set_Bolding : in out BOOLEAN; Set_Underlining : in out BOOLEAN ) is --| Notes (none) begin -- Pop if Number_Of_Stack_Elements = 0 then Error_Log.Write_Error(Error_Stack_Empty); else for I in Fof.Page_Attribute loop Fof.Set_Page_Attribute(Item, I, Current.Pages(I)); end loop; for I in Fof.Line_Attribute loop if I /= Fof.Fill_State_Before_Center then Fof.Set_Line_Attribute(Item, I, Current.Lines(I)); end if; end loop; Variable.Set_Cc(Current.Cc_Val); Variable.Set_Ec(Current.Ec_Val); Variable.Set_Fc(Current.Fc_Val); Variable.Set_Auto_Paragraph(Current.Auto_Paragraph); Set_Bolding := Current.Bolding; Set_Underlining := Current.Underlining; Variable.Set_Bold_Count(Current.Bold_Count); Variable.Set_Center_Count(Current.Center_Count); Variable.Set_Underline_Count(Current.Ul_Count); if Current.Last /= null then Current := Current.Last; end if; Number_Of_Stack_Elements := Number_Of_Stack_Elements - 1; end if; end Pop; -- .................................. -- . . -- . Push . BODY -- . . -- .................................. procedure Push ( Item : in Formatted_Output_File.File; Set_Bolding : in BOOLEAN; Set_Underlining : in BOOLEAN ) is --| Notes (none) Rover : STACK_ELEMENT_POINTER; begin -- Push if Number_Of_Stack_Elements = 0 then Current := new STACK_ELEMENT; else if Current.Next = null then Current.Next := new STACK_ELEMENT; Rover := Current.Next; Rover.Last := Current; end if; Current := Current.Next; end if; for I in Fof.Page_Attribute loop Current.Pages(I) := Fof.Get_Page_Attribute(Item, I); end loop; for I in Fof.Line_Attribute loop Current.Lines(I) := Fof.Get_Line_Attribute(Item, I); end loop; Current.Cc_Val := Variable.Cc; Current.Ec_Val := Variable.Ec; Current.Fc_Val := Variable.Fc; Current.Auto_Paragraph := Variable.Is_Auto_Paragraph; Current.Bolding := Set_Bolding; Current.Underlining := Set_Underlining; Current.Bold_Count := Variable.Bold_Count; Current.Center_Count := Variable.Center_Count; Current.Ul_Count := Variable.Underline_Count; Number_Of_Stack_Elements := Number_Of_Stack_Elements + 1; exception -- Push when others => Error_Log.Write_Error(Error_Stack_Overflow); end Push; end Environment; --:::::::::: --err_body.a --:::::::::: -- ********************************** -- * * -- * Error_Log * BODY -- * * -- ********************************** with Console; with Output_File; with Variable; package body Error_Log is --| Notes (none) --| --| Modifications --| 08/16/89 Rick Conn Initial Version Is_Open : BOOLEAN := false; Error_File : Output_File.File_Type; Output_To_Stdio : BOOLEAN := false; Error_Count : NATURAL := 0; Warning_Count : NATURAL := 0; -- .................................. -- . . -- . Open . BODY -- . . -- .................................. procedure Open ( File_Name : in STRING ) is --| Notes (none) begin -- Open if File_Name'Length > 0 then Output_File.Create(Error_File, File_Name); Is_Open := true; Output_To_Stdio := false; else Is_Open := true; Output_To_Stdio := true; end if; exception -- Open -- Open -- Open when others => Is_Open := true; Output_To_Stdio := true; end Open; -- .................................. -- . . -- . Write_Location . SPEC & BODY -- . . -- .................................. procedure Write_Location is --| Notes (none) begin -- Write_Location if Output_To_Stdio then Console.Put_Line("(" & Variable.Get_File_Name & ":" & NATURAL'Image(Variable.Line_Number) & ")"); else Output_File.Put_Line(Error_File, "(" & Variable.Get_File_Name & ":" & NATURAL'Image(Variable.Line_Number) & ")"); end if; end Write_Location; -- .................................. -- . . -- . Write_Error . BODY -- . . -- .................................. procedure Write_Error ( Message : in STRING ) is --| Notes (none) begin -- Write_Error if not Is_Open then Open(""); end if; if Output_To_Stdio then Console.Put("Error : " & Message); else Output_File.Put(Error_File, "Error : " & Message); end if; Write_Location; Error_Count := Error_Count + 1; end Write_Error; -- .................................. -- . . -- . Write_Warning . BODY -- . . -- .................................. procedure Write_Warning ( Message : in STRING ) is --| Notes (none) begin -- Write_Warning if not Is_Open then Open(""); end if; if Output_To_Stdio then Console.Put("Warning : " & Message); else Output_File.Put(Error_File, "Warning : " & Message); end if; Write_Location; Warning_Count := Warning_Count + 1; end Write_Warning; -- .................................. -- . . -- . Close . BODY -- . . -- .................................. procedure Close is --| Notes (none) begin -- Close if Is_Open then if not Output_To_Stdio then Output_File.Close(Error_File); end if; end if; Console.Put(" "); if Error_Count = 0 then Console.Put("No Errors, "); else Console.Put(NATURAL'Image(Error_Count) & " Error(s), "); end if; if Warning_Count = 0 then Console.Put("No Warnings"); else Console.Put(NATURAL'Image(Warning_Count) & " Warning(s)"); end if; Console.New_Line; end Close; end Error_Log; --:::::::::: --fof_body.a --:::::::::: -- ********************************** -- * * -- * Formatted_Output_File * BODY -- * * -- ********************************** with Command_Symbols; with Dyn; with Error_Log; with Output_File; package body Formatted_Output_File is --| Notes (none) --| --| Modifications --| 08/16/89 Rick Conn Initial version --| 02/26/90 Rick Conn Remove trailing spaces from @n subtype HF is Dyn.Dyn_String; type HF_SECTION is ( LEFT, CENTER, RIGHT ); type HF_LINES is array (Header_Footer_Line, HF_SECTION) of HF; Header_Footer_Default : constant HF_LINES := (others => (others => Dyn.D_String(" "))); subtype LINE is -- very long line for STRING (1 .. Maximum_Line_Length * 5); -- invisible words pragma Format_Off; type FILE_OBJECT is record Output_Is_Open : BOOLEAN := false; -- has file been opened? Output_Is_Empty : BOOLEAN; -- has anything been output? Line_Is_Empty : BOOLEAN; -- is anything in Current_Line? Page_Attr : Page_Attribute_List; -- left margin, etc. Line_Attr : Line_Attribute_List; -- fill, etc (misnomer) Page_Num : Page_Number; -- # of current page Line_Num : Line_Number; -- # of line now being built Even_Header : HF_LINES; -- for even pages Odd_Header : HF_LINES; -- for odd pages Even_Footer : HF_LINES; -- for even pages Odd_Footer : HF_LINES; -- for odd pages Current_Line : LINE; -- line being built Index : NATURAL; -- index of next char to place -- into Current_Line Char_Count : NATURAL; -- number of visible chars -- in Current_Line Last_Char : CHARACTER; -- last char in Current_Line Page_Number_Id : CHARACTER; -- xlates into page number -- in headers and footers Pn_Format : Numeric_Format; -- arabic, lower_ & upper_roman Pn_String : Dyn.Dyn_String; -- text of page number File_Id : Output_File.File_Type; -- for Text_IO end record; pragma Format_On; use Command_Symbols; -- .................................. -- . . -- . Is_Punctuation . SPEC & BODY -- . . -- .................................. function Is_Punctuation ( Item : in CHARACTER ) return BOOLEAN is --| Purpose --| Is_Punctuation returns TRUE if Item is one of the characters in --| PUNCTUATION_CHARS. --| --| Exceptions (none) --| Notes (none) Result : BOOLEAN := false; begin -- Is_Punctuation case Item is when '.' | ',' | '!' | '?' | ';' => Result := true; when others => Result := false; end case; return Result; end Is_Punctuation; -- .................................. -- . . -- . Simple_Break_Page . SPEC -- . . -- .................................. procedure Simple_Break_Page ( Item : in File ); -- .................................. -- . . -- . Pnum_As_String . SPEC & BODY -- . . -- .................................. function Pnum_As_String ( Value : in Page_Number; Format : in Numeric_Format ) return STRING is --| Purpose --| Pnum_As_String outputs a string (with optional leading blanks) --| which contains the input number's representation in ARABIC, --| LOWER_ROMAN, or UPPER_ROMAN forms. --| --| Exceptions (none) --| --| Notes --| Value should be less than 1000 if output as a Roman numeral. Result : STRING (1 .. 20) := (others => ' '); Rover -- Set for leading space : NATURAL := Result'First; Ones : NATURAL := 0; Tens : NATURAL := 0; Hundreds : NATURAL := 0; -- .................................. -- . . -- . Pnum_As_String.Put . SPEC & BODY -- . . -- .................................. procedure Put ( Item : in CHARACTER ) is --| Purpose --| Put places a character into the Result buffer, incrementing Rover. --| --| Exceptions (none) --| Notes (none) begin -- Put Rover := Rover + 1; Result(Rover) := Item; end Put; -- .................................. -- . . -- . Pnum_As_String.Output . SPEC & BODY -- . . -- .................................. procedure Output ( Value : in NATURAL; Lower : in CHARACTER; Middle : in CHARACTER; Upper : in CHARACTER ) is --| Purpose --| Output outputs the appropriate Roman characters representing --| Value into the string Result, incrementing the pointer Rover --| as it goes. Value must be between 1 and 9, inclusive. --| --| Exceptions (none) --| Notes (none) begin -- Output if Value < 4 then for I in 1 .. Value loop Put(Lower); end loop; elsif Value = 4 then Put(Lower); Put(Middle); elsif (Value >= 5) and (Value < 9) then Put(Middle); if Value > 5 then for I in 1 .. Value - 5 loop Put(Lower); end loop; end if; else Put(Lower); Put(Upper); end if; end Output; -- .................................. -- . . -- . Pnum_As_String.Divide . SPEC & BODY -- . . -- .................................. procedure Divide ( Value : in NATURAL ) is --| Purpose --| Divide sets the number of Thousands, Hundreds, Tens, and Ones --| in the passed value for Roman numeral computation. --| --| Exceptions (none) --| Notes (none) Temp : NATURAL := Value; begin -- Divide if Temp >= 100 then Hundreds := Temp / 100; Temp := Temp - Hundreds * 100; end if; if Temp >= 10 then Tens := Temp / 10; Temp := Temp - Tens * 10; end if; Ones := Temp; end Divide; begin -- Pnum_As_String case Format is when Arabic => return Page_Number'Image(Value); when Lower_Roman => if NATURAL(Value) >= 1000 then Put('z'); Put('z'); Put('z'); else Divide(NATURAL(Value)); if Hundreds > 0 then Output(Hundreds, 'c', 'd', 'm'); end if; if Tens > 0 then Output(Tens, 'x', 'l', 'c'); end if; if Ones > 0 then Output(Ones, 'i', 'v', 'x'); end if; end if; when Upper_Roman => if NATURAL(Value) >= 1000 then Put('Z'); Put('Z'); Put('Z'); else Divide(NATURAL(Value)); if Hundreds > 0 then Output(Hundreds, 'C', 'D', 'M'); end if; if Tens > 0 then Output(Tens, 'X', 'L', 'C'); end if; if Ones > 0 then Output(Ones, 'I', 'V', 'X'); end if; end if; end case; return Result(1 .. Rover); exception when others => Error_Log.Write_Error(Error_Internal_Pnum); return " "; end Pnum_As_String; -- .................................. -- . . -- . Start_Line . SPEC & BODY -- . . -- .................................. procedure Start_Line ( Item : in File ) is --| Purpose --| This is an internal routine not specified in the package --| specification. It is used to initialize the Current_Line --| field of the Item object and the associated fields. It sets --| the left margin. --| --| Exceptions (none) --| Notes (none) begin -- Start_Line if Item.Page_Attr(Temp_Indent) > 0 then Item.Index := Item.Page_Attr(Temp_Indent) + Item.Page_Attr(Page_Offset); Item.Page_Attr(Temp_Indent) := 0; else Item.Index := Item.Page_Attr(Left_Margin) + Item.Page_Attr(Left_Indent) + Item.Page_Attr(Page_Offset); end if; if Item.Index < 1 then Item.Index := 1; end if; Item.Char_Count := Item.Index - 1; Item.Current_Line(1 .. Item.Index) := (others => ' '); Item.Last_Char := ' '; Item.Line_Is_Empty := false; end Start_Line; -- .................................. -- . . -- . Space_Lines . SPEC & BODY -- . . -- .................................. procedure Space_Lines ( Item : in File ) is --| Purpose --| This is an internal routine not specified in the package --| specification. It is used to output additional blank lines --| based on the LINE_SPACING setting. --| --| Exceptions (none) --| Notes (none) begin -- Space_Lines if Item.Page_Attr(Line_Spacing) > 0 then if Test_Page(Item, Line_Number(Item.Page_Attr(Line_Spacing))) then for I in 1 .. Item.Page_Attr(Line_Spacing) loop Output_File.New_Line(Item.File_Id); Item.Line_Num := Item.Line_Num + 1; end loop; else Simple_Break_Page(Item); end if; end if; end Space_Lines; -- .................................. -- . . -- . Justify_Line . SPEC & BODY -- . . -- .................................. procedure Justify_Line ( Item : in File ) is --| Notes --| This is an internal routine not specified in the package --| specification. It is used to fill the Current_Line --| with spaces so that the last character is on the right --| margin. --| --| Exceptions (none) --| Notes (none) Spaces_Required : constant NATURAL := Item.Page_Attr(Right_Margin) - Item.Page_Attr(Right_Indent) - Item.Char_Count + Item.Page_Attr(Page_Offset); Spaces_Left : NATURAL := Spaces_Required; -- .................................. -- . . -- . Justify_Line.Justify . SPEC & BODY -- . . -- .................................. function Justify ( Amount_Left : in NATURAL ) return NATURAL is --| Purpose --| Justify replaces single spaces in Item.Current_Line with --| double spaces until Amount is zero or the end of the --| line is reached. --| --| Exceptions (none) --| Notes (none) type PARSE_STATE is ( BEFORE_TEXT, IN_TEXT, IN_SPACES, DONE ); State : PARSE_STATE := BEFORE_TEXT; I -- index for Temp : NATURAL; Amount -- number of spaces to go : NATURAL := Amount_Left; Temp : LINE; Was_In_Spaces : BOOLEAN := false; begin -- Justify I := 1; for J in 1 .. Item.Index - 1 loop case State is when BEFORE_TEXT => Temp(I) := Item.Current_Line(J); I := I + 1; if Item.Current_Line(J) > ' ' then State := IN_TEXT; end if; when IN_TEXT => if Item.Current_Line(J) = ' ' then Temp(I) := ' '; I := I + 1; Temp(I) := ' '; I := I + 1; Amount := Amount - 1; Was_In_Spaces := true; if Amount = 0 then State := DONE; else State := IN_SPACES; end if; else Temp(I) := Item.Current_Line(J); I := I + 1; end if; when IN_SPACES => Temp(I) := Item.Current_Line(J); I := I + 1; if Item.Current_Line(J) /= ' ' then State := IN_TEXT; end if; when DONE => Temp(I) := Item.Current_Line(J); I := I + 1; end case; end loop; Item.Current_Line := Temp; Item.Index := I; if not Was_In_Spaces then Amount := 0; end if; return Amount; end Justify; begin -- Justify_Line while Spaces_Left > 0 loop Spaces_Left := Justify(Spaces_Left); end loop; end Justify_Line; -- .................................. -- . . -- . Conditional_Break_Page . SPEC & BODY -- . . -- .................................. procedure Conditional_Break_Page ( Item : in File ) is --| Purpose --| Checks to see if there are any lines left on the page and --| calls Break_Page if not. --| --| Exceptions (none) --| Notes (none) begin -- Conditional_Break_Page if INTEGER(Item.Line_Num) > Item.Page_Attr(Total_Lines) - (Item.Page_Attr(Bottom_Margin) + Item.Page_Attr(Footer_Lines)) then Simple_Break_Page(Item); end if; end Conditional_Break_Page; -- .................................. -- . . -- . Put_Header_Footer_Line . SPEC & BODY -- . . -- .................................. procedure Put_Header_Footer_Line ( Item : in File; Left_Text : in STRING; Center_Text : in STRING; Right_Text : in STRING; Page_Num : in STRING ) is --| Purpose --| This is an internal routine not specified in the package --| specification. It outputs a header or a footer line, placing --| the Page_Num string (which MUST be created by Current_Page) into --| it wherever the Item.Page_Number_Id character is found. The --| Left_Text string is left-justified against the left margin --| (first character starts on the left margin), the Center_Text --| string is centered between the left and right margins, and --| the Right_Text string is right-justified against the right --| margin (the last character falls on the right margin). --| --| Exceptions (none) --| Notes (none) Hf_Line : LINE := (others => ' '); Hf_Last : NATURAL := Item.Page_Attr(Right_Margin) + Item.Page_Attr(Page_Offset); Hf_Last_Save : NATURAL; Left_Text_Lower : constant NATURAL := Item.Page_Attr(Left_Margin) + Item.Page_Attr(Page_Offset); Left_Text_Upper : NATURAL; Right_Text_Lower : NATURAL; Right_Text_Upper : constant NATURAL := Item.Page_Attr(Right_Margin) + Item.Page_Attr(Page_Offset); Center_Point : constant NATURAL := (Right_Text_Upper - Left_Text_Lower) / 2 + Left_Text_Lower; Center_Text_Lower : NATURAL; Center_Text_Upper : NATURAL; Temp_String : LINE; Temp_Length : NATURAL; -- .............................................. -- . . -- . Put_Header_Footer_Line.Build_Temp_String . SPEC & BODY -- . . -- .............................................. procedure Build_Temp_String ( Str : in STRING ) is --| Purpose --| Build_Temp_String analyzes the input string for the Page_Number_Id --| character, building a new output string in the global Temp_String --| vector which contains the input string with the literal page --| number substituted for the Page_Number_Id character. --| --| Exceptions (none) --| Notes (none) J : NATURAL := 1; begin -- Build_Temp_String for I in Str'First .. Str'Last loop if Str(I) = Item.Page_Number_Id then for K in Page_Num'Range loop Temp_String(J) := Page_Num(K); J := J + 1; end loop; else Temp_String(J) := Str(I); J := J + 1; end if; end loop; Temp_Length := J - 1; J := 0; -- remove trailing spaces for I in reverse 1 .. Temp_Length loop if Temp_String(I) > ' ' then J := I; exit; end if; end loop; Temp_Length := J; Left_Text_Upper := Item.Page_Attr(Left_Margin) + Temp_Length - 1 + Item.Page_Attr(Page_Offset); Right_Text_Lower := Item.Page_Attr(Right_Margin) - Temp_Length + 1 + Item.Page_Attr(Page_Offset); Center_Text_Lower := Center_Point - Temp_Length / 2; Center_Text_Upper := Center_Text_Lower + Temp_Length - 1; end Build_Temp_String; begin -- Put_Header_Footer_Line if Left_Text'Length > 0 then Build_Temp_String(Left_Text); if Temp_Length < Right_Text_Upper - Left_Text_Lower + 1 then Hf_Line(Left_Text_Lower .. Left_Text_Upper) := Temp_String(1 .. Temp_Length); else Hf_Line(Left_Text_Lower .. Right_Text_Upper) := Temp_String(1 .. (Right_Text_Upper - Left_Text_Lower + 1)); end if; end if; if Right_Text'Length > 0 then Build_Temp_String(Right_Text); if Temp_Length < Right_Text_Upper - Left_Text_Lower + 1 then Hf_Line(Right_Text_Lower .. Right_Text_Upper) := Temp_String(1 .. Temp_Length); else Hf_Line(Left_Text_Lower .. Right_Text_Upper) := Temp_String(1 .. (Right_Text_Upper - Left_Text_Lower + 1)); end if; end if; if Center_Text'Length > 0 then Build_Temp_String(Center_Text); if Temp_Length < Right_Text_Upper - Left_Text_Lower + 1 then Hf_Line(Center_Text_Lower .. Center_Text_Upper) := Temp_String(1 .. Temp_Length); else Hf_Line(Left_Text_Lower .. Right_Text_Upper) := Temp_String(1 .. (Right_Text_Upper - Left_Text_Lower + 1)); end if; end if; Hf_Last_Save := Hf_Last; Hf_Last := 1; for I in reverse 1 .. Hf_Last_Save loop if Hf_Line(I) /= ' ' then Hf_Last := I; exit; end if; end loop; Output_File.Put_Line(Item.File_Id, Hf_Line(1 .. Hf_Last)); Item.Line_Num := Item.Line_Num + 1; exception when others => Error_Log.Write_Error(Error_Internal_Hf_Line); end Put_Header_Footer_Line; -- .................................. -- . . -- . Output_Top_Of_Page . SPEC & BODY -- . . -- .................................. procedure Output_Top_Of_Page ( Item : in File ) is --| Purpose --| This is an internal routine not specified in the package --| specification. Assuming that the output is at the top --| of page, it increments the Item.Page_Num, outputs --| the appropriate number of blank lines as per the Top_Margin, --| and outputs the header lines (distinguishing between even and --| odd pages). --| --| Exceptions (none) --| Notes (none) Is_Even : BOOLEAN; begin -- Output_Top_Of_Page Item.Line_Num := 1; if Item.Page_Attr(Top_Margin) > 0 then for I in 1 .. Item.Page_Attr(Top_Margin) loop Output_File.New_Line(Item.File_Id); Item.Line_Num := Item.Line_Num + 1; end loop; end if; if Item.Page_Attr(Header_Lines) > 0 then if Item.Page_Num / 2 * 2 = Item.Page_Num then Is_Even := true; else Is_Even := false; end if; for I in 1 .. Header_Footer_Line(Item.Page_Attr(Header_Lines)) loop if Is_Even then Put_Header_Footer_Line(Item, Dyn.Str(Item.Even_Header(I, LEFT)), Dyn.Str(Item.Even_Header(I, CENTER)), Dyn.Str(Item.Even_Header(I, RIGHT)), Current_Page(Item)); else Put_Header_Footer_Line(Item, Dyn.Str(Item.Odd_Header(I, LEFT)), Dyn.Str(Item.Odd_Header(I, CENTER)), Dyn.Str(Item.Odd_Header(I, RIGHT)), Current_Page(Item)); end if; end loop; end if; exception when others => Error_Log.Write_Error(Error_Internal_Top); end Output_Top_Of_Page; -- .................................. -- . . -- . Output_Bottom_Of_Page . BODY -- . . -- .................................. procedure Output_Bottom_Of_Page ( Item : in File ) is --| Purpose --| Output_Bottom_Of_Page determines how many blank lines are left --| in the text area (between the top margin/header combination and --| the bottom margin/footer combination) and outputs blank lines in --| order to reach the first footer line. It then outputs the --| footer (distinguishing between even and odd page footers) and --| advances over the bottom margin (with either blank lines or --| form feeds). --| --| Exceptions (none) --| Notes (none) Lines_Left : Line_Number; Is_Even : BOOLEAN; begin -- Output_Bottom_Of_Page Lines_Left := Line_Number(Item.Page_Attr(Total_Lines) - (Item.Page_Attr(Bottom_Margin) + Item.Page_Attr(Footer_Lines))) - Item.Line_Num + 1; if Lines_Left < 0 then Lines_Left := 0; end if; if Lines_Left > 0 then for I in 1 .. Lines_Left loop Output_File.New_Line(Item.File_Id); Item.Line_Num := Item.Line_Num + 1; end loop; end if; if Item.Page_Attr(Footer_Lines) > 0 then if Item.Page_Num / 2 * 2 = Item.Page_Num then Is_Even := true; else Is_Even := false; end if; for I in 1 .. Header_Footer_Line(Item.Page_Attr(Footer_Lines)) loop if Is_Even then Put_Header_Footer_Line(Item, Dyn.Str(Item.Even_Footer(I, LEFT)), Dyn.Str(Item.Even_Footer(I, CENTER)), Dyn.Str(Item.Even_Footer(I, RIGHT)), Current_Page(Item)); else Put_Header_Footer_Line(Item, Dyn.Str(Item.Odd_Footer(I, LEFT)), Dyn.Str(Item.Odd_Footer(I, CENTER)), Dyn.Str(Item.Odd_Footer(I, RIGHT)), Current_Page(Item)); end if; end loop; end if; if Item.Page_Attr(Bottom_Margin) > 0 then if Item.Line_Attr(Use_Form_Feed) = On then Output_File.New_Page(Item.File_Id); else for I in 1 .. Item.Page_Attr(Bottom_Margin) loop Output_File.New_Line(Item.File_Id); Item.Line_Num := Item.Line_Num + 1; end loop; end if; end if; exception when others => Error_Log.Write_Error(Error_Internal_Bottom); end Output_Bottom_Of_Page; -- .................................. -- . . -- . Simple_Break_Page . BODY -- . . -- .................................. procedure Simple_Break_Page ( Item : in File ) is --| Purpose --| Simple_Break_Page outputs to the bottom of the page and the --| top of the next page if paging is on. --| --| Exceptions (none) --| Notes (none) begin -- Simple_Break_Page if Item.Line_Attr(Paging) = On then Output_Bottom_Of_Page(Item); Item.Page_Num := Item.Page_Num + 1; Output_Top_Of_Page(Item); else Item.Line_Num := 1; end if; end Simple_Break_Page; -- .................................. -- . . -- . Simple_Break_Page . SPEC & BODY -- . . -- .................................. procedure Simple_Break_Page ( Item : in File; New_Page_Num : in Page_Number ) is --| Purpose --| Simple_Break_Page outputs to the bottom of the page and the --| top of the next page if paging is on. It sets the number of --| the new page to New_Page_Num. --| --| Exceptions (none) --| Notes (none) begin -- Simple_Break_Page if Item.Line_Attr(Paging) = On then Output_Bottom_Of_Page(Item); Item.Page_Num := New_Page_Num; Output_Top_Of_Page(Item); else Item.Page_Num := New_Page_Num; Item.Line_Num := 1; end if; end Simple_Break_Page; -- .................................. -- . . -- . Open . BODY -- . . -- .................................. procedure Open ( Item : in out File; File_Name : in STRING; Result : out Status ) is --| Notes --| Open the output file object and set --| defaults. Map the Output_File.Open status to the --| Formatted_Output_File.Open status. Local_Result : Status; begin -- Open Item := new FILE_OBJECT; begin Output_File.Create(Item.File_Id, File_Name); Local_Result := Ok; exception when others => Local_Result := Not_Ok; end; if Local_Result = Ok then Item.Output_Is_Open := true; Item.Output_Is_Empty := true; Item.Line_Is_Empty := true; Item.Page_Attr := Page_Attribute_Defaults; Item.Line_Attr := Line_Attribute_Defaults; Item.Page_Num := 0; Item.Line_Num := 1; Item.Even_Header := Header_Footer_Default; Item.Odd_Header := Header_Footer_Default; Item.Even_Footer := Header_Footer_Default; Item.Odd_Footer := Header_Footer_Default; Item.Page_Number_Id := Page_Number_Id_Default; Item.Pn_Format := Arabic; Item.Pn_String := Dyn.D_String(Page_Number_Id_Default); else Item.Output_Is_Open := false; end if; Result := Local_Result; end Open; -- .................................. -- . . -- . Close . BODY -- . . -- .................................. procedure Close ( Item : in File ) is --| Notes (none) begin -- Close if not Item.Output_Is_Open then raise File_Not_Open; end if; if Item.Line_Attr(Paging) = On then Break_Line(Item); Output_Bottom_Of_Page(Item); else Item.Line_Num := 1; end if; Output_File.Close(Item.File_Id); Item.Output_Is_Open := false; end Close; -- .................................. -- . . -- . Put_Invisible_Word . BODY -- . . -- .................................. procedure Put_Invisible_Word ( Item : in File; What : in STRING ) is --| Notes (none) begin -- Put_Invisible_Word if not Item.Output_Is_Open then raise File_Not_Open; end if; if Item.Output_Is_Empty then if Item.Line_Attr(Paging) = On then Item.Page_Num := Item.Page_Num + 1; Output_Top_Of_Page(Item); else Item.Line_Num := 1; end if; Item.Output_Is_Empty := false; end if; if Item.Line_Is_Empty then Start_Line(Item); end if; Item.Current_Line(Item.Index .. Item.Index + What'Length - 1) := What; Item.Index := Item.Index + What'Length; exception when others => Error_Log.Write_Error(Error_Internal_Put_Invisible); end Put_Invisible_Word; -- .................................. -- . . -- . Put_Word . BODY -- . . -- .................................. procedure Put_Word ( Item : in File; What : in STRING ) is --| Notes (none) Adjustment_Length : NATURAL; Adjustment_String : constant STRING -- 2 spaces := " "; -- .................................. -- . . -- . Put_Word.Put_What . SPEC & BODY -- . . -- .................................. procedure Put_What is --| Notes --| Put_What is used to place the What string into Item.Current_Line --| and update the other variables as necessary. Full_Adjustment_Length : NATURAL := Adjustment_Length + What'Length; Full_String_Length : NATURAL := Item.Char_Count + Full_Adjustment_Length; Lower_Index : NATURAL := Item.Index; Upper_Index : NATURAL := Item.Index + Full_Adjustment_Length - 1; begin -- Put_What Item.Current_Line(Lower_Index .. Upper_Index) := Adjustment_String(1 .. Adjustment_Length) & What; Item.Index := Upper_Index + 1; Item.Char_Count := Full_String_Length; Item.Last_Char := Item.Current_Line(Item.Index - 1); if Item.Line_Attr(Underline) = On then for I in 1 .. What'Length loop Item.Current_Line(Item.Index) := Ascii.Bs; Item.Index := Item.Index + 1; end loop; for I in What'range loop if Item.Line_Attr(Underline_Punct) = Off then if Is_Punctuation(What(I)) then Item.Current_Line(Item.Index) := What(I); else Item.Current_Line(Item.Index) := '_'; end if; else Item.Current_Line(Item.Index) := '_'; end if; Item.Index := Item.Index + 1; end loop; end if; if Item.Line_Attr(Bold) = On then for I in 1 .. What'Length loop Item.Current_Line(Item.Index) := Ascii.Bs; Item.Index := Item.Index + 1; end loop; for I in What'range loop Item.Current_Line(Item.Index) := What(I); Item.Index := Item.Index + 1; end loop; end if; exception when others => Error_Log.Write_Error(Error_Internal_Put_What); end Put_What; begin -- Put_Word if not Item.Output_Is_Open then raise File_Not_Open; end if; if Item.Output_Is_Empty then if Item.Line_Attr(Paging) = On then Item.Page_Num := Item.Page_Num + 1; Output_Top_Of_Page(Item); else Item.Line_Num := 1; end if; Item.Output_Is_Empty := false; end if; if Item.Line_Is_Empty then Adjustment_Length := 0; else case Item.Last_Char is when ' ' => Adjustment_Length := 0; when '.' => Adjustment_Length := 2; when others => Adjustment_Length := 1; end case; end if; if Item.Line_Attr(Fill) = On then if Item.Char_Count + Adjustment_Length + What'Length <= Item.Page_Attr(Right_Margin) - Item.Page_Attr(Right_Indent) + Item.Page_Attr(Page_Offset) then -- FILL is on and there is enough room on the line if Item.Line_Is_Empty then Start_Line(Item); end if; Put_What; else -- FILL is on, but not enough room on line if Item.Line_Attr(Justify) = On and not Item.Line_Is_Empty then Justify_Line(Item); end if; Break_Line(Item); Start_Line(Item); Adjustment_Length := 0; Put_What; end if; else -- No FILL, so no JUSTIFY either if Item.Line_Is_Empty then Start_Line(Item); end if; Put_What; end if; exception when others => Error_Log.Write_Error(Error_Internal_Put_Word); end Put_Word; -- .................................. -- . . -- . Put_Line . BODY -- . . -- .................................. procedure Put_Line ( Item : in File; What : in STRING ) is --| Notes (none) First : NATURAL; Last : NATURAL; Temp : NATURAL; type PARSE_STATE is ( IN_WHITE_SPACE, IN_TEXT ); Current_State : PARSE_STATE; begin -- Put_Line if not Item.Output_Is_Open then raise File_Not_Open; end if; if Item.Output_Is_Empty then if Item.Line_Attr(Paging) = On then Item.Page_Num := Item.Page_Num + 1; Output_Top_Of_Page(Item); else Item.Line_Num := 1; end if; Item.Output_Is_Empty := false; end if; if Item.Line_Attr(Fill) = Off then -- No FILL, so break previous line and output as a line Break_Line(Item); Conditional_Break_Page(Item); Start_Line(Item); -- for margin settings Item.Line_Is_Empty := true; if Item.Line_Attr(CENTER) = On then Temp := (Item.Page_Attr(Right_Margin) - Item.Page_Attr(Right_Indent)) - (Item.Page_Attr(Left_Margin) + Item.Page_Attr(Left_Indent)) + 1; if Temp > What'Length then Temp := (Temp - What'Length) / 2; for I in 1 .. Temp loop Output_File.Put(Item.File_Id, ' '); end loop; end if; end if; Output_File.Put(Item.File_Id, Item.Current_Line(1 .. Item.Char_Count) & What); if Item.Line_Attr(Bold) = On then for I in 1 .. What'Length loop Output_File.Put(Item.File_Id, Ascii.Bs); end loop; for I in What'range loop Output_File.Put(Item.File_Id, What(I)); end loop; end if; if Item.Line_Attr(Underline) = On then for I in 1 .. What'Length loop Output_File.Put(Item.File_Id, Ascii.Bs); end loop; for I in What'range loop if What(I) > ' ' then if Item.Line_Attr(Underline_Punct) = Off then if Is_Punctuation(What(I)) then Output_File.Put(Item.File_Id, What(I)); else Output_File.Put(Item.File_Id, '_'); end if; else Output_File.Put(Item.File_Id, '_'); end if; else Output_File.Put(Item.File_Id, What(I)); end if; end loop; end if; Output_File.New_Line(Item.File_Id); Item.Line_Num := Item.Line_Num + 1; Space_Lines(Item); else -- FILL, so parse out each word and use Put_Word to output Current_State := IN_WHITE_SPACE; for I in What'First .. What'Last loop case Current_State is when IN_WHITE_SPACE => if What(I) > ' ' then First := I; Current_State := IN_TEXT; end if; when IN_TEXT => if What(I) <= ' ' then Last := I - 1; Put_Word(Item, What(First .. Last)); Current_State := IN_WHITE_SPACE; end if; end case; end loop; if Current_State = IN_TEXT then Last := What'Last; Put_Word(Item, What(First .. Last)); end if; end if; exception when others => Error_Log.Write_Error(Error_Internal_Put_Line); end Put_Line; -- .................................. -- . . -- . Break_Line . BODY -- . . -- .................................. procedure Break_Line ( Item : in File ) is --| Notes --| Break_Line checks to see if the Current_Line is empty, and, --| if not, outputs it and sets the empty flag to TRUE. Page --| breaks are also handled if necessary. begin -- Break_Line if not Item.Output_Is_Open then raise File_Not_Open; end if; if not Item.Line_Is_Empty then Conditional_Break_Page(Item); Output_File.Put_Line(Item.File_Id, Item.Current_Line(1 .. Item.Index - 1)); Item.Line_Num := Item.Line_Num + 1; Space_Lines(Item); Item.Line_Is_Empty := true; end if; exception when others => Error_Log.Write_Error(Error_Internal_Break_Line); end Break_Line; -- .................................. -- . . -- . Current_Line . BODY -- . . -- .................................. function Current_Line ( Item : in File ) return Line_Number is --| Notes (none) begin -- Current_Line if not Item.Output_Is_Open then raise File_Not_Open; end if; return Item.Line_Num; end Current_Line; -- .................................. -- . . -- . Skip . BODY -- . . -- .................................. procedure Skip ( Item : in File; Number_Of_Lines : in Line_Number := 1 ) is --| Notes (none) begin -- Skip if not Item.Output_Is_Open then raise File_Not_Open; end if; if Item.Output_Is_Empty then if Item.Line_Attr(Paging) = On then Item.Page_Num := Item.Page_Num + 1; Output_Top_Of_Page(Item); else Item.Line_Num := 1; end if; Item.Output_Is_Empty := false; end if; Break_Line(Item); if Test_Page(Item, Number_Of_Lines + Number_Of_Lines * Line_Number(Item.Page_Attr(Line_Spacing))) then for I in 1 .. Number_Of_Lines loop Output_File.New_Line(Item.File_Id); Item.Line_Num := Item.Line_Num + 1; Space_Lines(Item); end loop; else Simple_Break_Page(Item); end if; exception when others => Error_Log.Write_Error(Error_Internal_Skip); end Skip; -- .................................. -- . . -- . Break_Page . BODY -- . . -- .................................. procedure Break_Page ( Item : in File ) is --| Notes --| Issues blank lines for the rest of the text area, outputs footer --| and bottom margin, and outputs header for next page. begin -- Break_Page if not Item.Output_Is_Open then raise File_Not_Open; end if; Break_Line(Item); Simple_Break_Page(Item); exception when others => Error_Log.Write_Error(Error_Internal_Break_Page_1); end Break_Page; -- .................................. -- . . -- . Break_Page . BODY -- . . -- .................................. procedure Break_Page ( Item : in File; New_Page_Num : in Page_Number ) is --| Notes (none) begin -- Break_Page if not Item.Output_Is_Open then raise File_Not_Open; end if; Break_Line(Item); Simple_Break_Page(Item, New_Page_Num); exception when others => Error_Log.Write_Error(Error_Internal_Break_Page_2); end Break_Page; -- .................................. -- . . -- . Current_Page . BODY -- . . -- .................................. function Current_Page ( Item : in File ) return Page_Number is --| Notes (none) begin -- Current_Page if not Item.Output_Is_Open then raise File_Not_Open; end if; return Item.Page_Num; end Current_Page; -- .................................. -- . . -- . Current_Page . BODY -- . . -- .................................. function Current_Page ( Item : in FILE ) return STRING is --| Notes (none) -- .................................. -- . . -- . Current_Page.Convert . SPEC & BODY -- . . -- .................................. function Convert ( Page_Number : in STRING ) return STRING is Result : STRING(1..80); Last : NATURAL := 0; -- .................................. -- . . -- . Current_Page.Convert.Enter . SPEC & BODY -- . . -- .................................. procedure Enter ( Item : in STRING ) is Start : NATURAL := Item'First; begin -- Enter if Item(Start) = ' ' then Start := Start + 1; end if; for I in Start .. Item'Last loop Last := Last + 1; Result(Last) := Item(I); end loop; end Enter; begin -- Convert for I in Page_Number'Range loop if Page_Number(I) /= Item.Page_Number_Id then Last := Last + 1; Result(Last) := Page_Number(I); else Enter(Pnum_As_String(Item.Page_Num, Item.Pn_Format)); end if; end loop; return Result(1..Last); end Convert; begin -- Current_Page if not Item.Output_Is_Open then raise File_Not_Open; end if; return Convert(Dyn.Str(Item.Pn_String)); end Current_Page; -- .................................. -- . . -- . Set_Page_Number_Format . BODY -- . . -- .................................. procedure Set_Page_Number_Format ( Item : in File; To : in NUMERIC_FORMAT; Format_String : in STRING ) is --| Notes (none) begin -- Set_Page_Number_Format if not Item.Output_Is_Open then raise File_Not_Open; end if; Item.Pn_Format := To; if Format_String'Length > 0 then Dyn.Clear(Item.Pn_String); Item.Pn_String := Dyn.D_String(Format_String); end if; end Set_Page_Number_Format; -- .................................. -- . . -- . Set_Page_Attribute . BODY -- . . -- .................................. procedure Set_Page_Attribute ( Item : in File; What : in Page_Attribute; To : in NATURAL ) is --| Notes (none) begin -- Set_Page_Attribute if not Item.Output_Is_Open then raise File_Not_Open; end if; Item.Page_Attr(What) := To; end Set_Page_Attribute; -- .................................. -- . . -- . Set_Line_Attribute . BODY -- . . -- .................................. procedure Set_Line_Attribute ( Item : in File; What : in Line_Attribute; To : in Off_On ) is --| Notes (none) begin -- Set_Line_Attribute if not Item.Output_Is_Open then raise File_Not_Open; end if; Item.Line_Attr(What) := To; if What = CENTER then if To = On then Item.Line_Attr(Fill_State_Before_Center) := Item.Line_Attr(Fill); Item.Line_Attr(Fill) := Off; else Item.Line_Attr(Fill) := Item.Line_Attr(Fill_State_Before_Center); end if; end if; end Set_Line_Attribute; -- .................................. -- . . -- . Get_Page_Attribute . BODY -- . . -- .................................. function Get_Page_Attribute ( Item : in File; What : in Page_Attribute ) return NATURAL is --| Notes (none) begin -- Get_Page_Attribute if not Item.Output_Is_Open then raise File_Not_Open; end if; return Item.Page_Attr(What); end Get_Page_Attribute; -- .................................. -- . . -- . Get_Line_Attribute . BODY -- . . -- .................................. function Get_Line_Attribute ( Item : in File; What : in Line_Attribute ) return Off_On is --| Notes (none) begin -- Get_Line_Attribute if not Item.Output_Is_Open then raise File_Not_Open; end if; return Item.Line_Attr(What); end Get_Line_Attribute; -- .................................. -- . . -- . Test_Page . BODY -- . . -- .................................. function Test_Page ( Item : in File; Number_Of_Lines : in Line_Number ) return BOOLEAN is --| Notes (none) begin -- Test_Page if not Item.Output_Is_Open then raise File_Not_Open; end if; return INTEGER(Number_Of_Lines) <= Item.Page_Attr(Total_Lines) - (Item. Page_Attr(Bottom_Margin) + Item.Page_Attr(Footer_Lines)) - INTEGER(Item.Line_Num); end Test_Page; -- .................................. -- . . -- . Set_Footer_Line . BODY -- . . -- .................................. procedure Set_Footer_Line ( Item : in File; Class : in Page_Kind; Number : in Header_Footer_Line; Left_Text : in STRING; Center_Text : in STRING; Right_Text : in STRING ) is --| Notes (none) begin -- Set_Footer_Line if not Item.Output_Is_Open then raise File_Not_Open; end if; case Class is when Even_Pages => Dyn.Clear(Item.Even_Footer(Number, LEFT)); Item.Even_Footer(Number, LEFT) := Dyn.D_String(Left_Text); Dyn.Clear(Item.Even_Footer(Number, CENTER)); Item.Even_Footer(Number, CENTER) := Dyn.D_String(Center_Text); Dyn.Clear(Item.Even_Footer(Number, RIGHT)); Item.Even_Footer(Number, RIGHT) := Dyn.D_String(Right_Text); when Odd_Pages => Dyn.Clear(Item.Odd_Footer(Number, LEFT)); Item.Odd_Footer(Number, LEFT) := Dyn.D_String(Left_Text); Dyn.Clear(Item.Odd_Footer(Number, CENTER)); Item.Odd_Footer(Number, CENTER) := Dyn.D_String(Center_Text); Dyn.Clear(Item.Odd_Footer(Number, RIGHT)); Item.Odd_Footer(Number, RIGHT) := Dyn.D_String(Right_Text); when All_Pages => Dyn.Clear(Item.Even_Footer(Number, LEFT)); Item.Even_Footer(Number, LEFT) := Dyn.D_String(Left_Text); Dyn.Clear(Item.Even_Footer(Number, CENTER)); Item.Even_Footer(Number, CENTER) := Dyn.D_String(Center_Text); Dyn.Clear(Item.Even_Footer(Number, RIGHT)); Item.Even_Footer(Number, RIGHT) := Dyn.D_String(Right_Text); Dyn.Clear(Item.Odd_Footer(Number, LEFT)); Item.Odd_Footer(Number, LEFT) := Dyn.D_String(Left_Text); Dyn.Clear(Item.Odd_Footer(Number, CENTER)); Item.Odd_Footer(Number, CENTER) := Dyn.D_String(Center_Text); Dyn.Clear(Item.Odd_Footer(Number, RIGHT)); Item.Odd_Footer(Number, RIGHT) := Dyn.D_String(Right_Text); end case; exception when others => Error_Log.Write_Error(Error_Internal_Set_Footer_Line); end Set_Footer_Line; -- .................................. -- . . -- . Set_Header_Line . BODY -- . . -- .................................. procedure Set_Header_Line ( Item : in File; Class : in Page_Kind; Number : in Header_Footer_Line; Left_Text : in STRING; Center_Text : in STRING; Right_Text : in STRING ) is --| Notes (none) begin -- Set_Header_Line if not Item.Output_Is_Open then raise File_Not_Open; end if; case Class is when Even_Pages => Dyn.Clear(Item.Even_Header(Number, LEFT)); Item.Even_Header(Number, LEFT) := Dyn.D_String(Left_Text); Dyn.Clear(Item.Even_Header(Number, CENTER)); Item.Even_Header(Number, CENTER) := Dyn.D_String(Center_Text); Dyn.Clear(Item.Even_Header(Number, RIGHT)); Item.Even_Header(Number, RIGHT) := Dyn.D_String(Right_Text); when Odd_Pages => Dyn.Clear(Item.Odd_Header(Number, LEFT)); Item.Odd_Header(Number, LEFT) := Dyn.D_String(Left_Text); Dyn.Clear(Item.Odd_Header(Number, CENTER)); Item.Odd_Header(Number, CENTER) := Dyn.D_String(Center_Text); Dyn.Clear(Item.Odd_Header(Number, RIGHT)); Item.Odd_Header(Number, RIGHT) := Dyn.D_String(Right_Text); when All_Pages => Dyn.Clear(Item.Even_Header(Number, LEFT)); Item.Even_Header(Number, LEFT) := Dyn.D_String(Left_Text); Dyn.Clear(Item.Even_Header(Number, CENTER)); Item.Even_Header(Number, CENTER) := Dyn.D_String(Center_Text); Dyn.Clear(Item.Even_Header(Number, RIGHT)); Item.Even_Header(Number, RIGHT) := Dyn.D_String(Right_Text); Dyn.Clear(Item.Odd_Header(Number, LEFT)); Item.Odd_Header(Number, LEFT) := Dyn.D_String(Left_Text); Dyn.Clear(Item.Odd_Header(Number, CENTER)); Item.Odd_Header(Number, CENTER) := Dyn.D_String(Center_Text); Dyn.Clear(Item.Odd_Header(Number, RIGHT)); Item.Odd_Header(Number, RIGHT) := Dyn.D_String(Right_Text); end case; exception when others => Error_Log.Write_Error(Error_Internal_Set_Header_Line); end Set_Header_Line; -- .................................. -- . . -- . Set_Page_Number_Id . BODY -- . . -- .................................. procedure Set_Page_Number_Id ( Item : in File; To : in CHARACTER ) is --| Notes (none) begin -- Set_Page_Number_Id if not Item.Output_Is_Open then raise File_Not_Open; end if; Item.Page_Number_Id := To; end Set_Page_Number_Id; -- .................................. -- . . -- . Set_Page_Number_Format . BODY -- . . -- .................................. procedure Set_Page_Number_Format ( Item : in File; To : in Numeric_Format ) is --| Notes (none) begin -- Set_Page_Number_Format if not Item.Output_Is_Open then raise File_Not_Open; end if; Item.Pn_Format := To; end Set_Page_Number_Format; -- .................................. -- . . -- . Page_Number_Format . BODY -- . . -- .................................. function Page_Number_Format ( Item : in FILE ) return NUMERIC_FORMAT is --| Notes (none) begin -- Page_Number_Format if not Item.Output_Is_Open then raise File_Not_Open; end if; return Item.Pn_Format; end Page_Number_Format; end Formatted_Output_File; --:::::::::: --idx_body.a --:::::::::: -- ********************************** -- * * -- * Index * BODY -- * * -- ********************************** with Command_Symbols; with Error_Log; with Output_File; package body Index is --| Notes (none) --| --| Modifications --| 08/16/89 Rick Conn Initial Version File_Id : Output_File.File_Type; Is_Open : BOOLEAN := false; Line_Length : NATURAL; use Command_Symbols; -- .................................. -- . . -- . Create . BODY -- . . -- .................................. procedure Create ( File_Name : in STRING; Line_Width : in NATURAL; Text_Line_Width : in NATURAL; Text_Line_Count : in NATURAL ) is --| Notes (none) begin -- Create Output_File.Create(File_Id, File_Name); Is_Open := true; Line_Length := Line_Width; Output_File.Put_Line(File_Id, NATURAL'Image(Text_Line_Width)); Output_File.Put_Line(File_Id, NATURAL'Image(Text_Line_Count)); exception -- Create when others => raise Create_Error; end Create; -- .................................. -- . . -- . Add_Entry . BODY -- . . -- .................................. procedure Add_Entry ( Text : in STRING; Page_Number : in STRING ) is --| Notes (none) Line : STRING (1 .. Line_Length) := (others => ' '); Last : NATURAL; Limit : NATURAL; begin -- Add_Entry if not Is_Open then raise Index_File_Not_Open; else if Text'Length + Page_Number'Length > Line_Length then Error_Log.Write_Warning(Warning_Index_Line_Truncation); end if; if Text'Length > Line_Length then Last := Text'First + Line_Length - 1; Limit := Line_Length; else Last := Text'Last; Limit := Text'Length; end if; Line(1 .. Limit) := Text(Text'First .. Last); if Page_Number'Length > Line_Length then Last := Page_Number'First + Line_Length - 1; Limit := 1; else Last := Page_Number'Last; Limit := Line_Length - Page_Number'Length + 1; end if; Line(Limit .. Line_Length) := Page_Number(Text'First .. Last); Output_File.Put_Line(File_Id, Line); end if; exception when others => Error_Log.Write_Error(Error_Internal_Add_Index_Entry); end Add_Entry; -- .................................. -- . . -- . Close . BODY -- . . -- .................................. procedure Close is --| Notes (none) begin -- Close if Is_Open then Output_File.Close(File_Id); end if; end Close; end Index; --:::::::::: --in_body.a --:::::::::: -- ********************************** -- * * -- * Input_File * BODY -- * * -- ********************************** with Text_IO; package body Input_File is --| Notes (none) --| --| Modifications --| 08/16/89 Rick Conn Initial Version type FILE_OBJECT is record Is_Open : BOOLEAN := false; File : Text_IO.File_Type; end record; -- .................................. -- . . -- . Open . BODY -- . . -- .................................. procedure Open ( Id : in out File_Type; File_Name : in STRING ) is --| Notes (none) begin -- Open Id := new FILE_OBJECT; Text_IO.Open(Id.File, Text_IO.In_File, File_Name); Id.Is_Open := true; exception -- Open -- Open when others => raise Cannot_Open_Input_File; end Open; -- .................................. -- . . -- . Get_Line . BODY -- . . -- .................................. procedure Get_Line ( Id : in out File_Type; Item : out STRING; Last : out NATURAL ) is --| Notes (none) begin -- Get_Line if Id.Is_Open then Text_IO.Get_Line(Id.File, Item, Last); end if; exception -- Get_Line -- Get_Line when others => raise Read_Error; end Get_Line; -- .................................. -- . . -- . End_Of_File . BODY -- . . -- .................................. function End_Of_File ( Id : in File_Type ) return BOOLEAN is --| Notes (none) begin -- End_Of_File if Id.Is_Open then return Text_IO.End_Of_File(Id.File); end if; exception -- End_Of_File -- End_Of_File when others => raise Read_Error; end End_Of_File; -- .................................. -- . . -- . Close . BODY -- . . -- .................................. procedure Close ( Id : in out File_Type ) is --| Notes (none) begin -- Close if Id.Is_Open then Text_IO.Close(Id.File); end if; end Close; end Input_File; --:::::::::: --mac_body.a --:::::::::: -- ********************************** -- * * -- * Macro * BODY -- * * -- ********************************** with Command_Symbols; with Dyn; with Error_Log; with Variable; package body Macro is --| Notes (none) --| --| Modifications --| 08/16/89 Rick Conn Initial Version --| 02/26/90 Rick Conn Init dummy ($n) parameters to null, not space Macro_Name_String_Length : constant := 20; subtype MACRO_NAME_STRING is STRING (1 .. Macro_Name_String_Length); type MACRO_LINE; type MACRO_LINE_POINTER is access MACRO_LINE; type MACRO_LINE is record Text : Dyn.Dyn_String; Next : MACRO_LINE_POINTER; end record; type MODE is ( CREATE_MACRO, OPEN_MACRO, INACTIVE ); type MACRO_DEFINITION is record Macro_Name : MACRO_NAME_STRING; Status : MODE := INACTIVE; First_Line : MACRO_LINE_POINTER := null; Next_Line : MACRO_LINE_POINTER := null; Last_Line : MACRO_LINE_POINTER := null; Next : Macro_Id := null; end record; First_Macro : Macro_Id := null; use Command_Symbols; -- .................................. -- . . -- . Locate . SPEC & BODY -- . . -- .................................. function Locate ( Macro_Name : in MACRO_NAME_STRING ) return Macro_Id is --| Purpose --| Locate is internal to the package Macro (as opposed to the --| other Locate which returns a MACRO_STATUS, which is exported). --| This Locate performs the same function as the other but --| returns the MACRO_ID of the located macro. If the macro named --| Macro_Name is not found, the value NULL is returned. --| --| Exceptions (none) --| Notes (none) Rover : Macro_Id := First_Macro; begin -- Locate while Rover /= null loop exit when Rover.Macro_Name = Macro_Name; Rover := Rover.Next; end loop; return Rover; end Locate; -- .................................. -- . . -- . Convert . SPEC & BODY -- . . -- .................................. function Convert ( Macro_Name : in STRING ) return MACRO_NAME_STRING is --| Purpose --| Convert is internal to the package Macro. --| It converts the passed string to a MACRO_NAME_STRING. --| --| Exceptions (none) --| Notes (none) Res_Start : constant NATURAL := Macro_Name'First; Res_End : constant NATURAL := Res_Start + Macro_Name_String_Length - 1; Result : MACRO_NAME_STRING := (others => ' '); begin -- Convert if Macro_Name'Length <= Macro_Name_String_Length then Result(1 .. Macro_Name'Length) := Macro_Name; else Result := Macro_Name(Res_Start .. Res_End); end if; return Result; end Convert; -- .................................. -- . . -- . Create . BODY -- . . -- .................................. procedure Create ( Macro_Name : in STRING; Id : in out Macro_Id; Status : out Macro_Status ) is --| Notes (none) Fill_String : constant MACRO_NAME_STRING := (others => ' '); Limit : INTEGER := Macro_Name_String_Length - Macro_Name'Length; begin -- Create Id := new MACRO_DEFINITION; Id.Macro_Name := Convert(Macro_Name); Id.Status := CREATE_MACRO; Status := Ok; exception -- Create -- Create when others => Status := Not_Ok; end Create; -- .................................. -- . . -- . Write . BODY -- . . -- .................................. procedure Write ( Id : in out Macro_Id; Line : in STRING ) is --| Notes (none) begin -- Write if Id.Status /= CREATE_MACRO then raise Macro_Not_In_Add_Mode; end if; if Id.Last_Line = null then Id.Last_Line := new MACRO_LINE; Id.First_Line := Id.Last_Line; else Id.Last_Line.Next := new MACRO_LINE; Id.Last_Line := Id.Last_Line.Next; end if; Id.Last_Line.Text := Dyn.D_String(Line); exception when others => Error_Log.Write_Error(Error_Internal_Macro_Write); end Write; -- .................................. -- . . -- . Open . BODY -- . . -- .................................. procedure Open ( Macro_Name : in STRING; Id : out Macro_Id; Status : out Macro_Status ) is --| Notes (none) Search_Result : Macro_Id; begin -- Open Search_Result := Locate(Convert(Macro_Name)); if Search_Result = null then Status := Not_Ok; else Status := Ok; end if; Id := Search_Result; if Search_Result /= null then Search_Result.Status := OPEN_MACRO; Search_Result.Next_Line := Search_Result.First_Line; end if; end Open; -- .................................. -- . . -- . Is_Empty . BODY -- . . -- .................................. function Is_Empty ( Id : in Macro_Id ) return BOOLEAN is --| Notes (none) begin -- Is_Empty if Id.Status /= OPEN_MACRO then raise Macro_Not_Open; end if; return Id.Next_Line = null; end Is_Empty; -- .................................. -- . . -- . Read . BODY -- . . -- .................................. procedure Read ( Id : in out Macro_Id; Item : out STRING; Last : out NATURAL ) is --| Notes (none) Local_Last : NATURAL; begin -- Read if Id.Status /= OPEN_MACRO then raise Macro_Not_Open; end if; if Id.Next_Line = null then Item(Item'First .. Item'First) := " "; Last := Item'First - 1; else Local_Last := Dyn.Length(Id.Next_Line.Text) + Item'First - 1; Item(Item'First .. Local_Last) := Dyn.Str(Id.Next_Line.Text); Last := Local_Last; Id.Next_Line := Id.Next_Line.Next; end if; end Read; -- .................................. -- . . -- . Close . BODY -- . . -- .................................. procedure Close ( Id : in out Macro_Id ) is --| Notes --| If the Id is in Create mode, Close adds it to the front of the --| main list. begin -- Close if Id.Status = CREATE_MACRO then if First_Macro = null then First_Macro := Id; else Id.Next := First_Macro; -- add to front of list First_Macro := Id; end if; end if; Id.Status := INACTIVE; end Close; -- .................................. -- . . -- . Locate . BODY -- . . -- .................................. function Locate ( Macro_Name : in STRING ) return Macro_Status is --| Notes (none) Result : Macro_Id; begin -- Locate Result := Locate(Convert(Macro_Name)); if Result /= null then return Ok; else return Not_Ok; end if; end Locate; -- .................................. -- . . -- . Define_Parameters . BODY -- . . -- .................................. procedure Define_Parameters ( Macro_Name : in STRING; Parameters : in STRING ) is --| Notes (none) Start : NATURAL; Stop : NATURAL; Number : STRING (1 .. 1) := "1"; type PARSE_STATE is ( IN_TEXT, IN_LAST, NOT_IN_TEXT ); State : PARSE_STATE := NOT_IN_TEXT; begin -- Define_Parameters Variable.Set_Var("0", Macro_Name); for I in Parameters'range loop case State is when NOT_IN_TEXT => if Parameters(I) > ' ' then if Number(1) = '9' then State := IN_LAST; else State := IN_TEXT; end if; Start := I; end if; when IN_LAST => null; when IN_TEXT => if Parameters(I) <= ' ' then Stop := I - 1; Variable.Set_Var(Number, Parameters(Start .. Stop)); Number(1) := CHARACTER'Succ(Number(1)); State := NOT_IN_TEXT; end if; end case; end loop; if (State = IN_LAST) or (State = IN_TEXT) then Variable.Set_Var(Number, Parameters(Start .. Parameters'Last)); else Variable.Set_Var(Number, " "); end if; while Number(1) /= '9' loop Number(1) := CHARACTER'Succ(Number(1)); Variable.Set_Var(Number, " "); end loop; exception when others => Error_Log.Write_Error(Error_Internal_Macro_Define); end Define_Parameters; end Macro; --:::::::::: --out_body.a --:::::::::: -- ********************************** -- * * -- * Output_File * BODY -- * * -- ********************************** with Text_IO; package body Output_File is --| Notes (none) --| --| Modifications --| 08/16/89 Rick Conn Initial Version --| 02/26/90 Rick Conn Fix bug in Already_Exists test type FILE_OBJECT is record File : Text_IO.File_Type; Is_Open : BOOLEAN := false; Is_Output_Enabled : BOOLEAN := true; end record; -- .................................. -- . . -- . Already_Exists . BODY -- . . -- .................................. function Already_Exists ( File_Name : in STRING ) return BOOLEAN is --| Notes (none) File : Text_IO.File_Type; Result : BOOLEAN := true; begin -- Already_Exists begin Text_IO.Open(File, Text_IO.In_File, File_Name); Text_IO.Close(File); exception when others => Result := false; end; return Result; end Already_Exists; -- .................................. -- . . -- . Delete . BODY -- . . -- .................................. function Delete ( File_Name : in STRING ) return BOOLEAN is --| Notes (none) File : Text_IO.File_Type; Result : BOOLEAN := true; begin -- Delete begin if Already_Exists(File_Name) then Text_IO.Open(File, Text_IO.Out_File, File_Name); Text_IO.Delete(File); end if; exception when others => Result := false; end; return Result; end Delete; -- .................................. -- . . -- . Create . BODY -- . . -- .................................. procedure Create ( Id : in out File_Type; File_Name : in STRING ) is --| Notes (none) begin -- Create Id := new FILE_OBJECT; Text_IO.Create(Id.File, Text_IO.Out_File, File_Name); Id.Is_Open := true; Id.Is_Output_Enabled := true; exception -- Create -- Create when others => raise Cannot_Create_Output_File; end Create; -- .................................. -- . . -- . Put . BODY -- . . -- .................................. procedure Put ( Id : in out File_Type; Item : in CHARACTER ) is --| Notes (none) begin -- Put if Id.Is_Open and Id.Is_Output_Enabled then Text_IO.Put(Id.File, Item); end if; exception -- Put -- Put when others => raise Write_Error; end Put; -- .................................. -- . . -- . Put . BODY -- . . -- .................................. procedure Put ( Id : in out File_Type; Item : in STRING ) is --| Notes (none) begin -- Put if Id.Is_Open and Id.Is_Output_Enabled then Text_IO.Put(Id.File, Item); end if; exception -- Put -- Put when others => raise Write_Error; end Put; -- .................................. -- . . -- . Put_Line . BODY -- . . -- .................................. procedure Put_Line ( Id : in out File_Type; Item : in STRING ) is --| Notes (none) begin -- Put_Line if Id.Is_Open and Id.Is_Output_Enabled then Text_IO.Put_Line(Id.File, Item); end if; exception -- Put_Line -- Put_Line when others => raise Write_Error; end Put_Line; -- .................................. -- . . -- . New_Line . BODY -- . . -- .................................. procedure New_Line ( Id : in out File_Type ) is --| Notes (none) begin -- New_Line if Id.Is_Open and Id.Is_Output_Enabled then Text_IO.New_Line(Id.File); end if; exception -- New_Line -- New_Line when others => raise Write_Error; end New_Line; -- .................................. -- . . -- . New_Page . BODY -- . . -- .................................. procedure New_Page ( Id : in out File_Type ) is --| Notes (none) begin -- New_Page if Id.Is_Open and Id.Is_Output_Enabled then Text_IO.New_Page(Id.File); end if; exception -- New_Page -- New_Page when others => raise Write_Error; end New_Page; -- .................................. -- . . -- . Enable_Output . BODY -- . . -- .................................. procedure Enable_Output ( Id : in out File_Type ) is --| Notes (none) begin -- Enable_Output Id.Is_Output_Enabled := true; end Enable_Output; -- .................................. -- . . -- . Disable_Output . BODY -- . . -- .................................. procedure Disable_Output ( Id : in out File_Type ) is --| Notes (none) begin -- Disable_Output Id.Is_Output_Enabled := false; end Disable_Output; -- .................................. -- . . -- . Close . BODY -- . . -- .................................. procedure Close ( Id : in out File_Type ) is --| Notes (none) begin -- Close if Id.Is_Open then Text_IO.Close(Id.File); end if; end Close; end Output_File; --:::::::::: --var_body.a --:::::::::: -- ********************************** -- * * -- * Variable * BODY -- * * -- ********************************** with Command_Symbols; with Dyn; with Error_Log; package body Variable is --| Notes (none) --| --| Modifications --| 08/16/89 Rick Conn Initial Version Ap_Flag : BOOLEAN := Default_Auto_Paragraph; Bd_Count : NATURAL := 0; Ce_Count : NATURAL := 0; Ul_Count : NATURAL := 0; Cc_Char : CHARACTER := Default_Cc; Ec_Char : CHARACTER := Default_Ec; Fc_Char : CHARACTER := Default_Fc; type NREG_ARRAY is array (Nreg) of NATURAL; Number : NREG_ARRAY := (others => 0); Input_File_Name : STRING (1 .. 100); Input_File_Name_Last : NATURAL; File_Line_Number : NATURAL; Var_Name_String_Length : constant := 20; subtype VAR_NAME_STRING is STRING (1 .. Var_Name_String_Length); type VAR_DEFINITION; type VAR_LIST_POINTER is access VAR_DEFINITION; type VAR_DEFINITION is record Var_Name : VAR_NAME_STRING; Text : Dyn.Dyn_String; Next : VAR_LIST_POINTER := null; end record; First_Var : VAR_LIST_POINTER := null; use Command_Symbols; -- .................................. -- . . -- . Set_Auto_Paragraph . BODY -- . . -- .................................. procedure Set_Auto_Paragraph ( Item : in BOOLEAN ) is --| Notes (none) begin -- Set_Auto_Paragraph Ap_Flag := Item; end Set_Auto_Paragraph; -- .................................. -- . . -- . Is_Auto_Paragraph . BODY -- . . -- .................................. function Is_Auto_Paragraph return BOOLEAN is --| Notes (none) begin -- Is_Auto_Paragraph return Ap_Flag; end Is_Auto_Paragraph; -- .................................. -- . . -- . Set_Bold_Count . BODY -- . . -- .................................. procedure Set_Bold_Count ( Value : in NATURAL ) is --| Notes (none) begin -- Set_Bold_Count Bd_Count := Value; end Set_Bold_Count; -- .................................. -- . . -- . Bold_Count . BODY -- . . -- .................................. function Bold_Count return NATURAL is --| Notes (none) begin -- Bold_Count return Bd_Count; end Bold_Count; -- .................................. -- . . -- . Set_Center_Count . BODY -- . . -- .................................. procedure Set_Center_Count ( Value : in NATURAL ) is --| Notes (none) begin -- Set_Center_Count Ce_Count := Value; end Set_Center_Count; -- .................................. -- . . -- . Center_Count . BODY -- . . -- .................................. function Center_Count return NATURAL is --| Notes (none) begin -- Center_Count return Ce_Count; end Center_Count; -- .................................. -- . . -- . Set_Underline_Count . BODY -- . . -- .................................. procedure Set_Underline_Count ( Value : in NATURAL ) is --| Notes (none) begin -- Set_Underline_Count Ul_Count := Value; end Set_Underline_Count; -- .................................. -- . . -- . Underline_Count . BODY -- . . -- .................................. function Underline_Count return NATURAL is --| Notes (none) begin -- Underline_Count return Ul_Count; end Underline_Count; -- .................................. -- . . -- . Set_Cc . BODY -- . . -- .................................. procedure Set_Cc ( Item : in CHARACTER ) is --| Notes (none) begin -- Set_Cc Cc_Char := Item; end Set_Cc; -- .................................. -- . . -- . Cc . BODY -- . . -- .................................. function Cc return CHARACTER is --| Notes (none) begin -- Cc return Cc_Char; end Cc; -- .................................. -- . . -- . Set_Ec . BODY -- . . -- .................................. procedure Set_Ec ( Item : in CHARACTER ) is --| Notes (none) begin -- Set_Ec Ec_Char := Item; end Set_Ec; -- .................................. -- . . -- . Ec . BODY -- . . -- .................................. function Ec return CHARACTER is --| Notes (none) begin -- Ec return Ec_Char; end Ec; -- .................................. -- . . -- . Set_Fc . BODY -- . . -- .................................. procedure Set_Fc ( Item : in CHARACTER ) is --| Notes (none) begin -- Set_Fc Fc_Char := Item; end Set_Fc; -- .................................. -- . . -- . Fc . BODY -- . . -- .................................. function Fc return CHARACTER is --| Notes (none) begin -- Fc return Fc_Char; end Fc; -- .................................. -- . . -- . Set_Nr . BODY -- . . -- .................................. procedure Set_Nr ( Item : in Nreg; Value : in NATURAL ) is --| Notes (none) begin -- Set_Nr Number(Item) := Value; end Set_Nr; -- .................................. -- . . -- . Nr . BODY -- . . -- .................................. function Nr ( Item : in Nreg ) return NATURAL is --| Notes (none) begin -- Nr return Number(Item); end Nr; -- .................................. -- . . -- . Nr . BODY -- . . -- .................................. procedure Nr ( Item : in Nreg; Value : out STRING; Last : out NATURAL ) is --| Notes (none) Buffer : STRING (1 .. 20); Length : NATURAL; Temp_Last : NATURAL; -- .................................. -- . . -- . Nr.Set_Buffer . SPEC & BODY -- . . -- .................................. procedure Set_Buffer ( Value : in STRING ) is --| Notes (none) begin -- Set_Buffer Buffer(1 .. Value'Length) := Value; Length := Value'Length; end Set_Buffer; begin -- Nr Set_Buffer(NATURAL'Image(Nr(Item))); Temp_Last := Value'First + Length - 2; Value(Value'First .. Temp_Last) := Buffer(2 .. Length); Last := Temp_Last; end Nr; -- .................................. -- . . -- . Convert . SPEC & BODY -- . . -- .................................. function Convert ( Var_Name : in STRING ) return VAR_NAME_STRING is --| Purpose --| Convert is internal to the package Variable. --| It converts the passed string to a VAR_NAME_STRING. --| --| Exceptions (none) --| Notes (none) Res_Start : constant NATURAL := Var_Name'First; Res_End : constant NATURAL := Res_Start + Var_Name_String_Length - 1; Result : VAR_NAME_STRING := (others => ' '); begin -- Convert if Var_Name'Length <= Var_Name_String_Length then Result(1 .. Var_Name'Length) := Var_Name; else Result := Var_Name(Res_Start .. Res_End); end if; return Result; end Convert; -- .................................. -- . . -- . Locate . SPEC & BODY -- . . -- .................................. function Locate ( Var_Name : in VAR_NAME_STRING ) return VAR_LIST_POINTER is --| Purpose --| Locate is internal to the package Variable. --| It returns a pointer to the named variable or NULL if not found. --| --| Exceptions (none) --| Notes (none) Rover : VAR_LIST_POINTER := First_Var; begin -- Locate while Rover /= null loop exit when Rover.Var_Name = Var_Name; Rover := Rover.Next; end loop; return Rover; end Locate; -- .................................. -- . . -- . Set_Var . BODY -- . . -- .................................. procedure Set_Var ( Name : in STRING; Value : in STRING ) is --| Notes (none) Target : VAR_NAME_STRING := Convert(Name); Target_Pointer : VAR_LIST_POINTER := Locate(Target); Temp : VAR_LIST_POINTER; begin -- Set_Var if Target_Pointer = null then Temp := new VAR_DEFINITION; Temp.Var_Name := Target; Temp.Text := Dyn.D_String(Value); Temp.Next := First_Var; First_Var := Temp; else Dyn.Clear(Target_Pointer.Text); Target_Pointer.Text := Dyn.D_String(Value); end if; exception when others => Error_Log.Write_Error(Error_Internal_Set_Var); end Set_Var; -- .................................. -- . . -- . Var . BODY -- . . -- .................................. function Var ( Name : in STRING ) return STRING is --| Notes (none) Target : VAR_NAME_STRING := Convert(Name); Target_Pointer : VAR_LIST_POINTER := Locate(Target); begin -- Var if Target_Pointer = null then return ""; else return Dyn.Str(Target_Pointer.Text); end if; end Var; -- .................................. -- . . -- . Var . BODY -- . . -- .................................. procedure Var ( Name : in STRING; Value : out STRING; Last : out NATURAL ) is --| Notes (none) Target : VAR_NAME_STRING := Convert(Name); Tp : VAR_LIST_POINTER := Locate(Target); Local_Last : NATURAL; begin -- Var if Tp = null then Last := Value'First - 1; Value(Value'First) := ' '; else Local_Last := Dyn.Length(Tp.Text) + Value'First - 1; Value(Value'First .. Local_Last) := Dyn.Str(Tp.Text); Last := Local_Last; end if; end Var; -- .................................. -- . . -- . Set_File_Name . BODY -- . . -- .................................. procedure Set_File_Name ( Name : in STRING ) is --| Notes (none) begin -- Set_File_Name if Name'Length <= Input_File_Name'Length then Input_File_Name(1 .. Name'Length) := Name; Input_File_Name_Last := Name'Length; else Input_File_Name := Name(Name'First .. Name'First + Input_File_Name'Length - 1); Input_File_Name_Last := Input_File_Name'Length; end if; File_Line_Number := 0; end Set_File_Name; -- .................................. -- . . -- . Get_File_Name . BODY -- . . -- .................................. function Get_File_Name return STRING is --| Notes (none) begin -- Get_File_Name return Input_File_Name(1 .. Input_File_Name_Last); end Get_File_Name; -- .................................. -- . . -- . Set_Line_Number . BODY -- . . -- .................................. procedure Set_Line_Number ( Value : in NATURAL ) is --| Notes (none) begin -- Set_Line_Number File_Line_Number := Value; end Set_Line_Number; -- .................................. -- . . -- . Increment_Line_Number . BODY -- . . -- .................................. procedure Increment_Line_Number is --| Notes (none) begin -- Increment_Line_Number File_Line_Number := File_Line_Number + 1; exception when others => Error_Log.Write_Error(Error_Internal_Increment); end Increment_Line_Number; -- .................................. -- . . -- . Line_Number . BODY -- . . -- .................................. function Line_Number return NATURAL is --| Notes (none) begin -- Line_Number return File_Line_Number; end Line_Number; end Variable; --:::::::::: --wp_body.a --:::::::::: -- ********************************** -- * * -- * Word_Processor * BODY -- * * -- ********************************** with Command; with Command_Symbols; with Error_Log; with Formatted_Output_File; with Macro; with Parse; with Variable; with Input_File; package body Word_Processor is --| Notes (none) --| --| Modifications --| 08/16/89 Rick Conn Initial Version --| 02/26/90 Rick Conn Add Disable Underlining Flag --| 02/26/90 Rick Conn Remove trailing spaces from variables use Command; -- for visibility of "=" use Command_Symbols; use Formatted_Output_File; use Macro; Max_Line_Length : constant := 400; Output_File : Formatted_Output_File.File; Is_Open : BOOLEAN := false; Last_Line_Was_Blank : BOOLEAN := true; package Cmd renames Command; package Csym renames Command_Symbols; package Fof renames Formatted_Output_File; -- .................................. -- . . -- . Expand . SPEC & BODY -- . . -- .................................. procedure Expand ( In_Out_Line : in out STRING; Last : in out NATURAL ) is --| Purpose --| Expand expands the line in the buffer Inline, expanding tabs into --| spaces, replacing number register references with the appropriate --| values, and replacing variable name references with the appropriate --| values. The result is placed back into Inline and Inlast. --| This procedure is internal to Wp_Body. --| --| Exceptions (none) --| Notes (not done) Temp : STRING (1 .. In_Out_Line'Length); Temp_Last : NATURAL := 0; Var : STRING (1 .. In_Out_Line'Length); Var_Last : NATURAL; Result_Last : NATURAL; Rover : NATURAL := In_Out_Line'First; type EXPANSION_STATE is ( IN_TEXT, IN_ESCAPE, IN_BRACED_VARIABLE, IN_VARIABLE ); Current_State : EXPANSION_STATE := IN_TEXT; -- .................................. -- . . -- . Expand.Expand_Variable . SPEC & BODY -- . . -- .................................. procedure Expand_Variable is --| Purpose --| Expand_Variable locates the current variable and places --| its value into the output. --| --| Exceptions (none) --| Notes (none) Value : STRING (1 .. In_Out_Line'Length); Value_Last : NATURAL; Value_First : NATURAL; Value_Last_Temp : NATURAL; begin -- Expand_Variable if (Var_Last = 2) then if (Var(1) = 'n') and (Var(2) in Variable.Nreg) then Variable.Nr(Var(2), Value, Value_Last); else Variable.Var(Var(1 .. Var_Last), Value, Value_Last); end if; else Variable.Var(Var(1 .. Var_Last), Value, Value_Last); end if; if Value_Last > 0 then Value_Last_Temp := 0; for I in reverse 1 .. Value_Last loop -- remove trailing spaces if Value(I) > ' ' then Value_Last_Temp := I; exit; end if; end loop; Value_Last := Value_Last_Temp; Value_First := Value_Last + 1; for I in 1 .. Value_Last loop -- remove leading spaces if Value(I) > ' ' then Value_First := I; exit; end if; end loop; for I in Value_First .. Value_Last loop Temp_Last := Temp_Last + 1; Temp(Temp_Last) := Value(I); end loop; else Error_Log.Write_Error(Error_Variable_Name); end if; end Expand_Variable; -- .................................. -- . . -- . Expand.Process_In_Text . SPEC & BODY -- . . -- .................................. procedure Process_In_Text ( Index : in NATURAL ) is --| Purpose --| Process_In_Text performs the character processing and state --| switching required when the Current_State is processing a --| text character as opposed to a variable character. This can --| happen in any of the three EXPANSION_STATEs. --| --| Exceptions (none) --| Notes (none) begin -- Process_In_Text if In_Out_Line(Index) = Ascii.Ht then Temp_Last := Temp_Last + 1; Temp(Temp_Last) := ' '; while Temp_Last mod 8 /= 1 loop Temp_Last := Temp_Last + 1; Temp(Temp_Last) := ' '; end loop; else if In_Out_Line(Index) = Variable.Fc then Current_State := IN_VARIABLE; Var_Last := 0; else if In_Out_Line(Index) = Variable.Ec then Current_State := IN_ESCAPE; else Temp_Last := Temp_Last + 1; Temp(Temp_Last) := In_Out_Line(Index); end if; end if; end if; end Process_In_Text; begin -- Expand for I in In_Out_Line'First .. Last loop case Current_State is when IN_ESCAPE => Temp_Last := Temp_Last + 1; Temp(Temp_Last) := In_Out_Line(I); Current_State := IN_TEXT; when IN_TEXT => Process_In_Text(I); when IN_BRACED_VARIABLE => if In_Out_Line(I) = '}' then Expand_Variable; Current_State := IN_TEXT; else Var_Last := Var_Last + 1; Var(Var_Last) := In_Out_Line(I); end if; when IN_VARIABLE => if In_Out_Line(I) = '{' then Current_State := IN_BRACED_VARIABLE; else if ((In_Out_Line(I) >= '0') and (In_Out_Line(I) <= '9')) or ((In_Out_Line(I) >= 'a') and (In_Out_Line(I) <= 'z')) or ((In_Out_Line(I) >= 'A') and (In_Out_Line(I) <= 'Z')) then Var_Last := Var_Last + 1; Var(Var_Last) := In_Out_Line(I); else Expand_Variable; Current_State := IN_TEXT; Process_In_Text(I); end if; end if; end case; end loop; if (Current_State = IN_VARIABLE) or (Current_State = IN_BRACED_VARIABLE) then Expand_Variable; end if; Result_Last := In_Out_Line'First + Temp_Last - 1; In_Out_Line(In_Out_Line'First .. Result_Last) := Temp(1 .. Temp_Last); Last := In_Out_Line'First - 1; for I in reverse In_Out_Line'First .. Result_Last loop if In_Out_Line(I) > ' ' then Last := I; exit; end if; end loop; exception -- Expand when others => Error_Log.Write_Error(Error_Expansion); end Expand; -- .................................. -- . . -- . Open_Output_File . BODY -- . . -- .................................. function Open_Output_File ( File_Name : in STRING; Page_Offset : in NATURAL; Disable_Bolding : in BOOLEAN; Disable_Underlining : in BOOLEAN ) return Operation_Status is --| Notes (none) Result : Fof.Status; Returned_Result : Operation_Status := Ok; begin -- Open_Output_File if not Is_Open then Fof.Open(Output_File, File_Name, Result); if Result = Fof.Not_Ok then Returned_Result := Not_Ok; else Is_Open := true; Returned_Result := Ok; Fof.Set_Page_Attribute(Output_File, Fof.Page_Offset, Page_Offset); if Disable_Bolding then Command.Disable_Bolding; end if; if Disable_Underlining then Command.Disable_Underlining; end if; end if; else Returned_Result := Not_Ok; end if; return Returned_Result; exception when others => Error_Log.Write_Error(Error_Internal_Open); return Not_Ok; end Open_Output_File; -- .................................. -- . . -- . Process_Source_File . BODY -- . . -- .................................. function Process_Source_File ( File_Name : in STRING ) return Operation_Status is --| Notes (none) File_Id : Input_File.File_Type; Result : Operation_Status := Ok; My_Cmd : Csym.Command_Id; My_Macro : Macro.Macro_Id; Mresult : Macro.Macro_Status; subtype LINE is STRING (1 .. Max_Line_Length); Inline : LINE; Inlast : NATURAL; Verb : LINE; Cvlast : NATURAL; Tail : LINE; Ctlast : NATURAL; Current_Line_Number : NATURAL; type OPERATIONAL_STATE is ( IN_MACRO, IN_TEXT ); State : OPERATIONAL_STATE := IN_TEXT; -- .................................. -- . . -- . Process_Source_File.Is_Blank . BODY -- . . -- .................................. function Is_Blank ( Item : in STRING ) return BOOLEAN is --| Purpose --| Is_Blank determines if the indicated string contains any --| non-white characters. --| --| Exceptions (none) --| Notes (none) Result : BOOLEAN := true; begin -- Is_Blank for I in Item'range loop if Item(I) > ' ' then Result := false; exit; end if; end loop; return Result; end Is_Blank; begin -- Process_Source_File begin Input_File.Open(File_Id, File_Name); exception when others => Result := Not_Ok; end; Variable.Set_File_Name(File_Name); if Result = Ok then while (not Input_File.End_Of_File(File_Id)) or (State = IN_MACRO) loop if State = IN_TEXT then Input_File.Get_Line(File_Id, Inline, Inlast); Variable.Increment_Line_Number; else if not Macro.Is_Empty(My_Macro) then Macro.Read(My_Macro, Inline, Inlast); else Macro.Close(My_Macro); State := IN_TEXT; exit when Input_File.End_Of_File(File_Id); Input_File.Get_Line(File_Id, Inline, Inlast); Variable.Increment_Line_Number; end if; end if; if Inlast > 0 and then not Is_Blank(Inline(1 .. Inlast)) then -- Line is not blank Expand(Inline, Inlast); if Inline(1) /= Variable.Cc then -- Line is not a dot command if Variable.Is_Auto_Paragraph then if Last_Line_Was_Blank or (Inline(1) <= ' ') then Fof.Skip(Output_File, 1); Cmd.Process(Csym.Temporary_Indent, "+5", Output_File, File_Id); end if; end if; Fof.Put_Line(Output_File, Inline(1 .. Inlast)); if Variable.Bold_Count > 0 then Variable.Set_Bold_Count(Variable.Bold_Count - 1); if Variable.Bold_Count = 0 then Fof.Set_Line_Attribute(Output_File, Fof.Bold, Fof.Off); end if; end if; if Variable.Bold_Count > 0 then Variable.Set_Bold_Count(Variable.Bold_Count - 1); if Variable.Bold_Count = 0 then Fof.Set_Line_Attribute(Output_File, Fof.Bold, Fof.Off); end if; end if; if Variable.Center_Count > 0 then Variable.Set_Center_Count(Variable.Center_Count - 1); if Variable.Center_Count = 0 then Fof.Set_Line_Attribute(Output_File, Fof.Center, Fof.Off); end if; end if; if Variable.Underline_Count > 0 then Variable.Set_Underline_Count(Variable.Underline_Count - 1); if Variable.Underline_Count = 0 then Fof.Set_Line_Attribute(Output_File, Fof.Underline, Fof.Off); end if; end if; else -- Line is a dot command Parse(Inline(2 .. Inlast), Verb, Tail, Cvlast, Ctlast); if Macro.Locate(Verb(1 .. Cvlast)) = Macro.Ok then Macro.Open(Verb(1 .. Cvlast), My_Macro, Mresult); if Mresult = Macro.Ok then State := IN_MACRO; end if; Macro.Define_Parameters(Verb(1 .. Cvlast), Tail(1 .. Ctlast)); else My_Cmd := Cmd.Identify(Verb(1 .. Cvlast)); if My_Cmd /= Csym.Unknown then if My_Cmd = Csym.Include then Current_Line_Number := Variable.Line_Number; end if; Cmd.Process(My_Cmd, Tail(1 .. Ctlast), Output_File, File_Id); if My_Cmd = Csym.Include then Variable.Set_File_Name(File_Name); Variable.Set_Line_Number(Current_Line_Number); end if; else Error_Log.Write_Error(Error_Unknown); end if; end if; end if; Last_Line_Was_Blank := false; else -- Line is blank if Fof.Get_Line_Attribute(Output_File, Fof.Fill) = Fof.Off then Fof.Put_Line(Output_File, ""); end if; Last_Line_Was_Blank := true; if Variable.Bold_Count > 0 then Variable.Set_Bold_Count(Variable.Bold_Count - 1); if Variable.Bold_Count = 0 then Fof.Set_Line_Attribute(Output_File, Fof.Bold, Fof.Off); end if; end if; if Variable.Center_Count > 0 then Variable.Set_Center_Count(Variable.Center_Count - 1); if Variable.Center_Count = 0 then Fof.Set_Line_Attribute(Output_File, Fof.Center, Fof.Off); end if; end if; if Variable.Underline_Count > 0 then Variable.Set_Underline_Count(Variable.Underline_Count - 1); if Variable.Underline_Count = 0 then Fof.Set_Line_Attribute(Output_File, Fof.Underline, Fof.Off); end if; end if; end if; end loop; Input_File.Close(File_Id); end if; return Result; exception when others => return Not_Ok; end Process_Source_File; -- .................................. -- . . -- . Close_Output_File . BODY -- . . -- .................................. procedure Close_Output_File is --| Notes (none) begin -- Close_Output_File Fof.Close(Output_File); Is_Open := false; end Close_Output_File; end Word_Processor;